[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 12a982d 1/2: Merge remote-tracking branch 'savannah/
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp 12a982d 1/2: Merge remote-tracking branch 'savannah/master' into HEAD |
|
Date: |
Sun, 9 Aug 2020 09:27:20 -0400 (EDT) |
branch: feature/native-comp
commit 12a982d9789052d8e85efcacb4b311f4876c882a
Merge: 80d7f71 8e82baf
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Merge remote-tracking branch 'savannah/master' into HEAD
---
.gitignore | 1 +
ChangeLog.3 | 2 +-
admin/authors.el | 1 -
configure.ac | 82 +-
doc/emacs/calendar.texi | 5 +
doc/emacs/display.texi | 4 +
doc/emacs/files.texi | 7 +-
doc/emacs/help.texi | 10 +
doc/emacs/killing.texi | 4 +-
doc/emacs/misc.texi | 19 +-
doc/lispref/display.texi | 9 +
doc/lispref/edebug.texi | 10 +
doc/lispref/os.texi | 6 +-
doc/misc/emacs-mime.texi | 20 +-
doc/misc/eww.texi | 16 +
doc/misc/message.texi | 60 ++
doc/misc/tramp.texi | 87 +-
etc/MACHINES | 25 +-
etc/NEWS | 160 ++++
etc/PROBLEMS | 135 ++--
etc/emacs-mail.desktop | 10 +
etc/themes/leuven-theme.el | 686 ++++++++++++----
etc/tutorials/TUTORIAL | 14 +-
lib/c++defs.h | 4 +-
lib/cdefs.h | 2 +-
lib/count-leading-zeros.h | 3 +-
lib/count-trailing-zeros.h | 3 +-
lib/gnulib.mk.in | 13 +-
lisp/Makefile.in | 1 -
lisp/arc-mode.el | 115 ++-
lisp/bookmark.el | 13 +
lisp/buff-menu.el | 60 +-
lisp/button.el | 51 +-
lisp/calendar/cal-dst.el | 16 +-
lisp/calendar/calendar.el | 7 +
lisp/calendar/solar.el | 10 +-
lisp/calendar/time-date.el | 15 +
lisp/cus-dep.el | 10 +-
lisp/cus-edit.el | 5 +-
lisp/custom.el | 14 +
lisp/dired-aux.el | 20 +-
lisp/dired.el | 2 +-
lisp/emacs-lisp/autoload.el | 16 +-
lisp/emacs-lisp/byte-opt.el | 29 +-
lisp/emacs-lisp/byte-run.el | 17 +-
lisp/emacs-lisp/bytecomp.el | 93 +--
lisp/emacs-lisp/cl-generic.el | 16 +-
lisp/emacs-lisp/cl-macs.el | 7 +-
lisp/emacs-lisp/edebug.el | 31 +
lisp/emacs-lisp/hierarchy.el | 579 +++++++++++++
lisp/emacs-lisp/seq.el | 1 +
lisp/epa-file.el | 30 +-
lisp/erc/erc-capab.el | 16 +-
lisp/erc/erc-compat.el | 10 +-
lisp/erc/erc-dcc.el | 10 +-
lisp/erc/erc-list.el | 28 +-
lisp/erc/erc-log.el | 2 +-
lisp/erc/erc-match.el | 6 +-
lisp/erc/erc-networks.el | 2 +-
lisp/erc/erc.el | 132 ++-
lisp/files.el | 2 -
lisp/finder.el | 2 +-
lisp/generic-x.el | 2 +-
lisp/gnus/gnus-art.el | 34 +-
lisp/gnus/gnus-icalendar.el | 3 +-
lisp/gnus/gnus-sum.el | 2 +-
lisp/gnus/gnus-util.el | 1 +
lisp/gnus/gnus-win.el | 2 +-
lisp/gnus/message.el | 201 ++++-
lisp/gnus/mm-decode.el | 6 +
lisp/gnus/mm-view.el | 10 +-
lisp/gnus/mml-sec.el | 12 +-
lisp/gnus/mml.el | 13 +-
lisp/gnus/smime.el | 3 +
lisp/help-fns.el | 44 +
lisp/hi-lock.el | 4 +-
lisp/ibuf-ext.el | 6 +-
lisp/image-file.el | 12 +-
lisp/image-mode.el | 153 +++-
lisp/image/image-converter.el | 14 +-
lisp/international/ja-dic-cnv.el | 13 +-
lisp/mouse.el | 5 +-
lisp/net/browse-url.el | 136 +---
lisp/net/eww.el | 18 +
lisp/net/tramp-adb.el | 323 ++++----
lisp/net/tramp-sh.el | 462 ++++++-----
lisp/net/tramp.el | 169 +++-
lisp/outline.el | 11 +-
lisp/play/snake.el | 1 +
lisp/progmodes/cperl-mode.el | 45 +-
lisp/progmodes/project.el | 8 +-
lisp/progmodes/sh-script.el | 2 +-
lisp/progmodes/sql.el | 20 +
lisp/recentf.el | 3 +-
lisp/saveplace.el | 12 +-
lisp/scroll-lock.el | 2 +-
lisp/simple.el | 37 +-
lisp/skeleton.el | 101 +--
lisp/so-long.el | 88 +-
lisp/subr.el | 6 +-
lisp/tar-mode.el | 50 ++
lisp/textmodes/css-mode.el | 2 +-
lisp/textmodes/sgml-mode.el | 10 +-
lisp/thingatpt.el | 2 +-
lisp/vc/vc-hg.el | 61 +-
lisp/wdired.el | 15 +-
lisp/whitespace.el | 25 +-
lisp/wid-edit.el | 57 ++
lisp/x-dnd.el | 4 +-
m4/alloca.m4 | 14 +-
m4/gnulib-common.m4 | 6 +-
m4/gnulib-comp.m4 | 2 +-
m4/largefile.m4 | 2 +-
m4/libgmp.m4 | 88 +-
src/alloc.c | 52 +-
src/buffer.c | 6 -
src/bytecode.c | 11 +-
src/callint.c | 4 -
src/data.c | 6 -
src/dispnew.c | 7 -
src/editfns.c | 3 -
src/emacs-module.c | 8 -
src/emacs.c | 1 -
src/frame.c | 39 +-
src/fringe.c | 5 +-
src/gmalloc.c | 16 +-
src/image.c | 20 +-
src/lisp.h | 42 +-
src/nsimage.m | 12 +
src/nsterm.h | 3 +
src/nsterm.m | 12 +
src/pdumper.c | 6 +-
src/process.c | 97 ++-
src/ptr-bounds.h | 79 --
src/regex-emacs.c | 6 -
src/search.c | 6 -
src/xdisp.c | 54 +-
src/xfns.c | 2 +-
test/README | 5 +
test/data/mml-sec/.gpg-v21-migrated | 0
test/data/mml-sec/gpg-agent.conf | 5 +
.../02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key | Bin 0 -> 797 bytes
.../171B444DE92BEF997229000D9784118A94EEC1C9.key | Bin 0 -> 526 bytes
.../19FFEBC04DF3E037E16F6A4474DCB7984406975D.key | Bin 0 -> 841 bytes
.../1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key | Bin 0 -> 797 bytes
.../293109315BE584AB2EFEFCFCAD64666221D8B36C.key | Bin 0 -> 526 bytes
.../335689599E1C0F66D73ADCF51E03EE36C97D121F.key | Bin 0 -> 797 bytes
.../40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key | Bin 0 -> 797 bytes
.../515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key | Bin 0 -> 798 bytes
.../5A11B1935C46D0B227A73978DCA1293A85604F1D.key | Bin 0 -> 798 bytes
.../62643CEBC7AEBE6817577A34399483700D76BD64.key | Bin 0 -> 526 bytes
.../680D01F368916A0021C14E3453B27B3C5F900683.key | Bin 0 -> 710 bytes
.../6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key | Bin 0 -> 798 bytes
.../78C17E134E86E691297F7B719B2F2CDF41976234.key | Bin 0 -> 527 bytes
.../7F714F4D9D9676638214991E96D45704E4FFC409.key | Bin 0 -> 798 bytes
.../854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key | Bin 0 -> 526 bytes
.../93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key | Bin 0 -> 709 bytes
.../A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key | Bin 0 -> 797 bytes
.../A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key | Bin 0 -> 710 bytes
.../AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key | Bin 0 -> 841 bytes
.../C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key | Bin 0 -> 841 bytes
.../C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key | Bin 0 -> 527 bytes
.../C67DAD345455EAD6D51368008FC3A53B8D195B5A.key | Bin 0 -> 710 bytes
.../CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key | Bin 0 -> 797 bytes
.../CC68630A06B048F5A91136C162C7A3273E20DE6F.key | Bin 0 -> 710 bytes
.../E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key | Bin 0 -> 797 bytes
.../F0117468BE801ED4B81972E159A98FDD4814DCEC.key | Bin 0 -> 797 bytes
.../F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key | Bin 0 -> 841 bytes
test/data/mml-sec/pubring.gpg | Bin 0 -> 13883 bytes
test/data/mml-sec/pubring.kbx | Bin 0 -> 3076 bytes
test/data/mml-sec/secring.gpg | Bin 0 -> 17362 bytes
test/data/mml-sec/trustdb.gpg | Bin 0 -> 1880 bytes
test/data/mml-sec/trustlist.txt | 26 +
test/lisp/calendar/time-date-tests.el | 14 +
test/lisp/emacs-lisp/bytecomp-tests.el | 5 +
test/lisp/emacs-lisp/cconv-tests.el | 160 ++++
test/lisp/emacs-lisp/cl-generic-tests.el | 38 +
test/lisp/emacs-lisp/edebug-tests.el | 94 +++
test/lisp/emacs-lisp/generator-tests.el | 4 +
test/lisp/emacs-lisp/hierarchy-tests.el | 556 +++++++++++++
test/lisp/erc/erc-tests.el | 47 ++
test/lisp/gnus/gnus-util-tests.el | 76 ++
test/lisp/gnus/mml-sec-tests.el | 895 +++++++++++++++++++++
test/lisp/net/browse-url-tests.el | 119 +++
test/lisp/net/network-stream-tests.el | 13 +
test/lisp/net/tramp-tests.el | 18 +-
test/lisp/saveplace-resources/saveplace | 4 +
test/lisp/saveplace-tests.el | 103 +++
test/lisp/vc/vc-tests.el | 3 +-
test/lisp/wdired-tests.el | 1 +
190 files changed, 6040 insertions(+), 1731 deletions(-)
diff --git a/.gitignore b/.gitignore
index aebd507..0bcd73e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -153,6 +153,7 @@ test/manual/etags/regexfile
test/manual/etags/ETAGS
test/manual/etags/CTAGS
test/manual/indent/*.new
+test/data/mml-sec/random_seed
# ctags, etags.
TAGS
diff --git a/ChangeLog.3 b/ChangeLog.3
index 4aa52a7..c8dd40b 100644
--- a/ChangeLog.3
+++ b/ChangeLog.3
@@ -58779,7 +58779,7 @@
* lisp/net/soap-client.el (soap-type-of): Optimize for Emacs≥26
-2018-07-17 Alex <agrambot@gmail.com>
+2018-07-17 Alexander Gramiak <agrambot@gmail.com>
Remove menu name from emacs-lisp-mode-map (Bug#27114)
diff --git a/admin/authors.el b/admin/authors.el
index 1c06917..cf9cf98 100644
--- a/admin/authors.el
+++ b/admin/authors.el
@@ -212,7 +212,6 @@ files.")
("Carlos Pita" "memeplex")
("Vinicius Jose Latorre" "viniciusjl")
("Gaby Launay" "galaunay")
- ("Alex Gramiak" "alex")
("Dick R. Chiang" "dickmao")
)
"Alist of author aliases.
diff --git a/configure.ac b/configure.ac
index 78fe1f9..76a3e6b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -749,44 +749,21 @@ case "${canonical}" in
opsys=aix4-2
;;
- ## Suns
- *-sun-solaris* \
- | i[3456]86-*-solaris2* | i[3456]86-*-sunos5* \
- | x86_64-*-solaris2* | x86_64-*-sunos5*)
+ ## Solaris
+ *-*-solaris* | *-*-sunos*)
case "${canonical}" in
i[3456]86-*-* ) ;;
amd64-*-*|x86_64-*-*) ;;
sparc* ) ;;
* ) unported=yes ;;
esac
- case "${canonical}" in
- *-sunos5.[1-9][0-9]* | *-solaris2.[1-9][0-9]* )
- opsys=sol2-10
- emacs_check_sunpro_c=yes
- ;;
- *-sunos5.[1-5]* | *-solaris2.[1-5]* ) unported=yes ;;
- ## Note that Emacs 23.1's NEWS said the following would be dropped.
- *-sunos5.6* | *-solaris2.6* )
- opsys=sol2-6
- RANLIB="ar -ts"
- ;;
- ## 5.7 EOL Aug 2008, 5.8 EOL Mar 2012.
- *-sunos5.[7-9]* | *-solaris2.[7-9]* )
- opsys=sol2-6
- emacs_check_sunpro_c=yes
- ;;
- esac
+ opsys=solaris
## Watch out for a compiler that we know will not work.
- case "${canonical}" in
- *-solaris* | *-sunos5* )
- if [ "x$CC" = x/usr/ucb/cc ]; then
- ## /usr/ucb/cc doesn't work;
- ## we should find some other compiler that does work.
- unset CC
- fi
- ;;
- *) ;;
- esac
+ if [ "$CC" = /usr/ucb/cc ]; then
+ ## /usr/ucb/cc doesn't work;
+ ## we should find some other compiler that does work.
+ unset CC
+ fi
;;
## QNX Neutrino
@@ -1477,14 +1454,11 @@ case "$opsys" in
mingw32)
UNEXEC_OBJ=unexw32.o
;;
- sol2-10)
+ solaris)
# Use the Solaris dldump() function, called from unexsol.c, to dump
# emacs, instead of the generic ELF dump code found in unexelf.c.
# The resulting binary has a complete symbol table, and is better
# for debugging and other observability tools (debuggers, pstack, etc).
- #
- # It is likely that dldump() works with older Solaris too, but this has
- # not been tested, so for now this change is for Solaris 10 or newer.
UNEXEC_OBJ=unexsol.o
;;
*)
@@ -1587,7 +1561,7 @@ case "$opsys" in
qnxnto) LIBS_SYSTEM="-lsocket" ;;
- sol2*) LIBS_SYSTEM="-lsocket -lnsl" ;;
+ solaris) LIBS_SYSTEM="-lsocket -lnsl" ;;
## Motif needs -lgen.
unixware) LIBS_SYSTEM="-lsocket -lnsl -lelf -lgen" ;;
@@ -1648,7 +1622,7 @@ case $opsys in
SYSTEM_TYPE=berkeley-unix
;;
- sol2* | unixware )
+ solaris | unixware )
SYSTEM_TYPE=usg-unix-v
;;
@@ -2292,7 +2266,7 @@ system_malloc=yes
test $with_unexec = yes &&
case "$opsys" in
## darwin ld insists on the use of malloc routines in the System framework.
- darwin | mingw32 | nacl | sol2-10) ;;
+ darwin | mingw32 | nacl | solaris) ;;
cygwin | qnxnto | freebsd)
hybrid_malloc=yes
system_malloc= ;;
@@ -2428,7 +2402,7 @@ if test "$ac_cv_header_pthread_h" && test "$opsys" !=
"mingw32"; then
# need special flags to disable these optimizations. For example, the
# definition of 'errno' in <errno.h>.
case $opsys in
- hpux* | sol*)
+ hpux* | solaris)
AC_DEFINE([_REENTRANT], 1,
[Define to 1 if your system requires this in multithreaded code.]);;
aix4-2)
@@ -2558,7 +2532,7 @@ fail;
## inoue@ainet.or.jp says Solaris has a bug related to X11R6-style
## XIM support.
case "$opsys" in
- sol2-*) : ;;
+ solaris) : ;;
*) AC_DEFINE(HAVE_X11R6_XIM, 1,
[Define if you have usable X11R6-style XIM support.])
;;
@@ -4600,11 +4574,13 @@ AC_CHECK_HEADERS(valgrind/valgrind.h)
AC_CHECK_MEMBERS([struct unipair.unicode], [], [], [[#include <linux/kd.h>]])
-AC_CHECK_FUNCS_ONCE([sbrk])
+AC_CHECK_FUNCS_ONCE([__lsan_ignore_object sbrk])
AC_FUNC_FORK
-AC_CHECK_FUNCS(snprintf __lsan_ignore_object)
+dnl AC_CHECK_FUNCS_ONCE wouldn’t be right for snprintf, which needs
+dnl the current CFLAGS etc.
+AC_CHECK_FUNCS(snprintf)
dnl Check for glib. This differs from other library checks in that
dnl Emacs need not link to glib unless some other library is already
@@ -4778,7 +4754,7 @@ if test "$USE_X_TOOLKIT" != "none"; then
fi
case $opsys in
- sol2* | unixware )
+ solaris | unixware )
dnl Some SVr4s don't define NSIG in sys/signal.h for ANSI environments;
dnl instead, there's a system variable _sys_nsig. Unfortunately, we
dnl need the constant to dimension an array. So wire in the appropriate
@@ -4791,7 +4767,7 @@ emacs_broken_SIGIO=no
case $opsys in
dnl SIGIO exists, but the feature doesn't work in the way Emacs needs.
- hpux* | nacl | openbsd | sol2* | unixware )
+ hpux* | nacl | openbsd | solaris | unixware )
emacs_broken_SIGIO=yes
;;
@@ -4840,7 +4816,7 @@ case $opsys in
esac
case $opsys in
- gnu-* | sol2-10 )
+ gnu-* | solaris )
dnl FIXME Can't we test if this exists (eg /proc/$$)?
AC_DEFINE(HAVE_PROCFS, 1, [Define if you have the /proc filesystem.])
;;
@@ -4969,7 +4945,7 @@ case $opsys in
AC_DEFINE(PTY_TTY_NAME_SPRINTF, [sprintf (pty_name, "/dev/pty/tty%c%x", c,
i);])
;;
- sol2* )
+ solaris )
dnl On SysVr4, grantpt(3) forks a subprocess, so do not use
dnl O_CLOEXEC when opening the pty, and keep the SIGCHLD handler
dnl from intercepting that death. If any child but grantpt's should die
@@ -4979,7 +4955,7 @@ case $opsys in
;;
unixware )
- dnl Comments are as per sol2*.
+ dnl Comments are as per solaris.
AC_DEFINE(PTY_OPEN, [fd = open (pty_name, O_RDWR | O_NONBLOCK)])
AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptsname (int), *ptyname; int
grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked,
SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt
(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1)
fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not
unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable
slave pty"); snprintf (pty_name, P [...]
;;
@@ -4987,7 +4963,7 @@ esac
case $opsys in
- sol2* | unixware )
+ solaris | unixware )
dnl This change means that we don't loop through allocate_pty too
dnl many times in the (rare) event of a failure.
AC_DEFINE(FIRST_PTY_LETTER, ['z'])
@@ -5082,7 +5058,7 @@ if test x$GCC = xyes; then
AC_DEFINE(GC_SETJMP_WORKS, 1)
else
case $opsys in
- aix* | dragonfly | freebsd | netbsd | openbsd | sol2* )
+ aix* | dragonfly | freebsd | netbsd | openbsd | solaris )
AC_DEFINE(GC_SETJMP_WORKS, 1)
;;
esac
@@ -5129,7 +5105,7 @@ case
$emacs_cv_func_sigsetjmp,$emacs_cv_alternate_stack,$opsys in
esac
case $opsys in
- sol2* | unixware )
+ solaris | unixware )
dnl TIOCGPGRP is broken in SysVr4, so we can't send signals to PTY
dnl subprocesses the usual way. But TIOCSIGNAL does work for PTYs,
dnl and this is all we need.
@@ -5139,7 +5115,7 @@ esac
case $opsys in
- hpux* | sol2* )
+ hpux* | solaris )
dnl Used in xfaces.c.
AC_DEFINE(XOS_NEEDS_TIME_H, 1, [Compensate for a bug in Xos.h on
some systems, where it requires time.h.])
@@ -5194,7 +5170,7 @@ case $opsys in
fi
;;
- sol2*)
+ solaris)
AC_DEFINE(USG, [])
AC_DEFINE(USG5_4, [])
AC_DEFINE(SOLARIS2, [], [Define if the system is Solaris.])
@@ -5259,7 +5235,7 @@ case $opsys in
reopen it in the child.])
;;
- sol2-10)
+ solaris)
AC_DEFINE(_STRUCTURED_PROC, 1, [Needed for system_process_attributes
on Solaris.])
;;
diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi
index fe51ad3..31db815 100644
--- a/doc/emacs/calendar.texi
+++ b/doc/emacs/calendar.texi
@@ -625,6 +625,11 @@ your time zone. Emacs displays the times of sunrise and
sunset
@emph{corrected for daylight saving time}. @xref{Daylight Saving},
for how daylight saving time is determined.
+@vindex calendar-use-numeric-time-zones
+ If you want to display numerical time zones (like @samp{"+0100"})
+instead of symbolic time zones (like @samp{"CET"}), set the
+@code{calendar-use-numeric-time-zones} variable to non-@code{nil}.
+
As a user, you might find it convenient to set the calendar location
variables for your usual physical location in your @file{.emacs} file.
If you are a system administrator, you may want to set these variables
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index e96e43b..75ef520 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -1334,6 +1334,10 @@ customize the variable @code{whitespace-line-column}.
@item newline
Highlight newlines.
+@item missing-newline-at-eof
+Highlight the final character if the buffer doesn't end with a newline
+character.
+
@item empty
Highlight empty lines at the beginning and/or end of the buffer.
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 5998326..2fa1ecc 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -2149,7 +2149,12 @@ To reset all transformations to the initial state, use
@findex image-previous-file
You can press @kbd{n} (@code{image-next-file}) and @kbd{p}
(@code{image-previous-file}) to visit the next image file and the
-previous image file in the same directory, respectively.
+previous image file in the same directory, respectively. These
+commands will consult the ``parent'' dired buffer to determine what
+the next/previous image file is. These commands also work when
+opening a file from archive files (like zip or tar files), and will
+then instead consult the archive mode buffer. If neither an archive
+nor a dired ``parent'' buffer can be found, a dired buffer is opened.
@findex image-mode-mark-file
@findex image-mode-unmark-file
diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi
index 167c32c..06ad5a5 100644
--- a/doc/emacs/help.texi
+++ b/doc/emacs/help.texi
@@ -220,6 +220,16 @@ documentation string of the command it runs.
command is not on any key, that means you must use @kbd{M-x} to run
it. @kbd{C-h w} runs the command @code{where-is}.
+@findex button-describe
+@findex widget-describe
+ Some modes in Emacs use various buttons (@pxref{Buttons,,,elisp, The
+Emacs Lisp Reference Manual}) and widgets
+(@pxref{Introduction,,,widget, Emacs Widgets}) that can be clicked to
+perform some action. To find out what function is ultimately invoked
+by these buttons, Emacs provides the @code{button-describe} and
+@code{widget-describe} commands, that should be run with point over
+the button.
+
@node Name Help
@section Help by Command or Variable Name
diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi
index 6b1f35e..bd7dbb6 100644
--- a/doc/emacs/killing.texi
+++ b/doc/emacs/killing.texi
@@ -577,7 +577,9 @@ regions to the primary selection entirely.
To insert the primary selection into an Emacs buffer, click
@kbd{mouse-2} (@code{mouse-yank-primary}) where you want to insert it.
-@xref{Mouse Commands}.
+@xref{Mouse Commands}. You can also use the normal Emacs yank command
+(@kbd{C-y}) to insert this text if @code{select-enable-primary} is set
+(@pxref{Clipboard}).
@cindex MS-Windows, and primary selection
MS-Windows provides no primary selection, but Emacs emulates it
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index e7547eb..cb9fc61 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -724,13 +724,15 @@ See the Eshell Info manual, which is distributed with
Emacs.
@kindex M-!
@findex shell-command
+@vindex shell-command-buffer-name
@kbd{M-!} (@code{shell-command}) reads a line of text using the
minibuffer and executes it as a shell command, in a subshell made just
for that command. Standard input for the command comes from the null
device. If the shell command produces any output, the output appears
-either in the echo area (if it is short), or in an Emacs buffer named
-@file{*Shell Command Output*}, displayed in another window (if the
-output is long). The variables @code{resize-mini-windows} and
+either in the echo area (if it is short), or in an Emacs buffer,
+displayed in another window (if the output is long). The name of
+this buffer is taken from the constant @code{shell-command-buffer-name}.
+The variables @code{resize-mini-windows} and
@code{max-mini-window-height} (@pxref{Minibuffer Edit}) control when
Emacs should consider the output to be too long for the echo area.
@@ -758,15 +760,16 @@ which is impossible to ignore.
@kindex M-&
@findex async-shell-command
+@vindex shell-command-buffer-name-async
A shell command that ends in @samp{&} is executed
@dfn{asynchronously}, and you can continue to use Emacs as it runs.
You can also type @kbd{M-&} (@code{async-shell-command}) to execute a
shell command asynchronously; this is exactly like calling @kbd{M-!}
with a trailing @samp{&}, except that you do not need the @samp{&}.
-The default output buffer for asynchronous shell commands is named
-@samp{*Async Shell Command*}. Emacs inserts the output into this
-buffer as it comes in, whether or not the buffer is visible in a
-window.
+The constant @code{shell-command-buffer-name-async} stores the name
+of the default output buffer for asynchronous shell commands.
+Emacs inserts the output into this buffer as it comes in,
+whether or not the buffer is visible in a window.
@vindex async-shell-command-buffer
If you want to run more than one asynchronous shell command at the
@@ -804,7 +807,7 @@ old region and replaces it with the output from the shell
command.
see what keys are in the buffer. If the buffer contains a GnuPG key,
type @kbd{C-x h M-| gpg @key{RET}} to feed the entire buffer contents
to @command{gpg}. This will output the list of keys to the
-@file{*Shell Command Output*} buffer.
+buffer named @code{shell-command-buffer-name}.
@vindex shell-file-name
The above commands use the shell specified by the variable
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 25eabd6..d3adb62 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -5572,6 +5572,15 @@ The value, @var{width}, specifies the width of the
image, in pixels.
@item :height @var{height}
The value, @var{height}, specifies the height of the image, in pixels.
+Note that @code{:width} and @code{:height} can only be used if passing
+in data that doesn't specify the width and height (e.g., a string or a
+vector containing the bits of the image). @acronym{XBM} files usually
+specify this themselves, and it's an error to use these two properties
+on these files. Also note that @code{:width} and @code{:height} are
+used by most other image formats to specify what the displayed image
+is supposed to be, which usually means performing some sort of
+scaling. This isn't supported for @acronym{XBM} images.
+
@item :stride @var{stride}
The number of bool vector entries stored for each row; the smallest
multiple of 8 greater than or equal to @var{width}.
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index d879f3d..6404e06 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1438,6 +1438,16 @@ name component for the definition. You can use this to
add a unique,
static component to the name of the definition. It may be used more
than once.
+@item :unique
+This construct is like @code{:name}, but generates unique names. It
+does not match an argument. The element following @code{:unique}
+should be a string; it is used as the prefix for an additional name
+component for the definition. You can use this to add a unique,
+dynamic component to the name of the definition. This is useful for
+macros that can define the same symbol multiple times in different
+scopes, such as @code{cl-flet}; @ref{Function Bindings,,,cl}. It may
+be used more than once.
+
@item arg
The argument, a symbol, is the name of an argument of the defining form.
However, lambda-list keywords (symbols starting with @samp{&})
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index 942bda1..504f0df 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -2687,9 +2687,9 @@ Emacs is restarted by the session manager.
@group
(defun save-yourself-test ()
- (insert "(save-current-buffer
- (switch-to-buffer \"*scratch*\")
- (insert \"I am restored\"))")
+ (insert
+ (format "%S" '(with-current-buffer "*scratch*"
+ (insert "I am restored"))))
nil)
@end group
@end example
diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi
index 2f38dcd..9180b4e 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -472,6 +472,13 @@ the case if you save it to disk and launch it in a
different way
to launch any external programs, set this variable to @code{nil} or
@code{ask}.
+@item mm-inline-font-lock
+@vindex mm-inline-font-lock
+If non-@code{nil}, inlined parts that support font locking (for
+instance, patches or code snippets) will be font-locked. This may be
+overriden by callers that have their own ways of enabling/inhibiting
+font locking.
+
@end table
@node Files and Directories
@@ -686,8 +693,17 @@ Valid values are @samp{inline} and @samp{attachment}
@item encoding
Valid values are @samp{7bit}, @samp{8bit}, @samp{quoted-printable} and
-@samp{base64} (@code{Content-Transfer-Encoding}). @xref{Charset
-Translation}.
+@samp{base64}. @xref{Charset
+Translation}. This parameter says what
+@code{Content-Transfer-Encoding} to use when sending the part, and is
+normally computed automatically.
+
+@item data-encoding
+This parameter says what encoding has been used on the data, and the
+data will be decoded before use. Valid values are
+@samp{quoted-printable} and @samp{base64}. This is useful when you
+have a part with binary data (for instance an image) inserted directly
+into the Message buffer inside the @samp{"<#part>...<#/part>"} tags.
@item description
A description of the part (@code{Content-Description}).
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index f9901b6..85be112 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -52,6 +52,7 @@ modify this GNU manual.''
* Overview::
* Basics::
* Advanced::
+* Command Line::
Appendices
* History and Acknowledgments::
@@ -337,6 +338,21 @@ thus allowing for the use of the usual substitutions, such
as
@code{\[eww-reload]} for the current key binding of the
@code{eww-reload} command.
+@node Command Line
+@chapter Command Line Usage
+
+It can be convenient to start eww directly from the command line. The
+@code{eww-browse} function can be used for that:
+
+@example
+emacs -f eww-browse https://gnu.org
+@end example
+
+This also allows registering Emacs as a @acronym{MIME} handler for the
+@samp{"text/x-uri"} media type. How to do that varies between
+systems, but typically you'd register the handler to call @samp{"emacs
+-f eww-browse %u"}.
+
@node History and Acknowledgments
@appendix History and Acknowledgments
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index bdd31b1..204a638 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -99,6 +99,7 @@ sending it.
* Resending:: Resending a mail message.
* Bouncing:: Bouncing a mail message.
* Mailing Lists:: Send mail to mailing lists.
+* System Mailer Setup:: Using Message as the system mailer.
@end menu
You can customize the Message Mode tool bar, see @kbd{M-x
@@ -529,6 +530,29 @@ It is considered good netiquette to honor MFT, as it is
assumed the
fellow who posted a message knows where the followups need to go
better than you do.
+
+@node System Mailer Setup
+@section System Mailer Setup
+@cindex mailto:
+
+Emacs can be set up as the system mailer, so that Emacs is opened when
+you click on @samp{mailto:} links in other programs.
+
+How this is done varies from system to system, but commonly there's a
+way to set the default application for a @acronym{MIME} type, and the
+relevant type here is @samp{x-scheme-handler/mailto;}.
+
+The application to start should be @samp{"emacs -f message-mailto %u"}.
+This will start Emacs, and then run the @code{message-mailto}
+command. It will parse the given @acronym{URL}, and set up a Message
+buffer with the given parameters.
+
+For instance, @samp{mailto:larsi@@gnus.org?subject=This+is+a+test}
+will open a Message buffer with the @samp{To:} header filled in with
+@samp{"larsi@@gnus.org"} and the @samp{Subject:} header with
+@samp{"This is a test"}.
+
+
@node Commands
@chapter Commands
@@ -883,6 +907,18 @@ is a list, valid members are @code{type},
@code{description} and
@code{nil}, don't ask for options. If it is @code{t}, ask the user
whether or not to specify options.
+@vindex message-screenshot-command
+@findex message-insert-screenshot
+@cindex screenshots
+@kindex C-c C-p
+If your system supports it, you can also insert screenshots directly
+into the Message buffer. The @kbd{C-c C-p}
+(@code{message-insert-screenshot}) command inserts the image into the
+buffer as an @acronym{MML} part, and puts an image text property on
+top. The @code{message-screenshot-command} variable says what
+external command to use to take the screenshot. It defaults to
+@code{"import png:-"}, which is an ImageMagick command.
+
You can also create arbitrarily complex multiparts using the @acronym{MML}
language (@pxref{Composing, , Composing, emacs-mime, The Emacs MIME
Manual}).
@@ -1006,6 +1042,7 @@ and/or encrypted messages as explained in the following.
* Signing and encryption:: Signing and encrypting commands.
* Using S/MIME:: Using S/MIME
* Using OpenPGP:: Using OpenPGP
+* OpenPGP Header:: Adding OpenPGP headers to messages.
* Passphrase caching:: How to cache passphrases
* PGP Compatibility:: Compatibility with older implementations
* Encrypt-to-self:: Reading your own encrypted messages
@@ -1215,6 +1252,29 @@ according to two different standards, namely
@acronym{PGP} or
@code{mml-default-sign-method} determine which variant to prefer,
@acronym{PGP/MIME} by default.
+@node OpenPGP Header
+@subsection OpenPGP Header
+
+The @samp{OpenPGP} header can be used to provide information about the
+sender's OpenPGP key. This is a formalization and modernization of
+the non-standard @samp{X-PGP-Key} (etc.) headers that have been in use
+for a long time. For more details, see
+@uref{https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header}.
+
+@vindex message-openpgp-header
+To use this in Message, say:
+
+@lisp
+(add-hook 'message-send-hook 'message-add-openpgp-header)
+@end lisp
+
+@noindent
+then customize the @code{message-openpgp-header} variable according to
+your PGP setup. The variable is a list of the key ID, the key URL or
+ASCII armored key, and the protection preference, one of
+@samp{"unprotected"}, @samp{"sign"}, @samp{"encrypt"} or
+@samp{"signencrypt"}.
+
@node Passphrase caching
@subsection Passphrase caching
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index b419511..ae6fe3d 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -2053,6 +2053,13 @@ 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{"direct-async-process"}
+
+When this property is non-@code{nil}, an alternative, more performant
+implementation of @code{make-process} and
+@code{start-file-process} is applied. @ref{Improving performance of
+asynchronous remote processes} for a discussion of constraints.
+
@item @t{"posix"}
Connections using the @option{smb} method check, whether the remote
@@ -2098,7 +2105,7 @@ To improve performance and accuracy of remote file access,
@file{/usr/bin}, which are reasonable for most hosts. To accommodate
differences in hosts and paths, for example, @file{/bin:/usr/bin} on
Debian GNU/Linux or
-@file{/usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin} on
+@file{/usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/developerstudio12.6/bin} on
Solaris, @value{tramp} queries the remote host with @command{getconf
PATH} and updates the symbol @code{tramp-default-remote-path}.
@@ -2458,10 +2465,9 @@ overwrite as follows:
@lisp
@group
-(add-to-list
- 'tramp-connection-properties
- `(,(regexp-quote "192.168.0.1")
- "remote-copy-args" (("-l") ("%r"))))
+(add-to-list 'tramp-connection-properties
+ `(,(regexp-quote "192.168.0.1")
+ "remote-copy-args" (("-l") ("%r"))))
@end group
@end lisp
@@ -3373,7 +3379,7 @@ host. Example:
@end example
@command{tail} command outputs continuously to the local buffer,
-@file{*Async Shell Command*}
+named @code{shell-command-buffer-name-async}
@kbd{M-x auto-revert-tail-mode @key{RET}} runs similarly showing
continuous output.
@@ -3527,6 +3533,70 @@ To open @command{powershell} as a remote shell, use this:
@end lisp
+@anchor{Improving performance of asynchronous remote processes}
+@subsection Improving performance of asynchronous remote processes
+@cindex Asynchronous remote processes
+@findex make-process
+@findex start-file-process
+
+@value{tramp}'s implementation of @code{make-process} and
+@code{start-file-process} requires a serious overhead for
+initialization, every process invocation. This is needed for handling
+interactive dialogues when connecting the remote host (like providing
+a password), and initial environment setup.
+
+Sometimes, this is not needed. Instead of starting a remote shell and
+running the command afterwards, it is sufficient to run the command
+directly. @value{tramp} supports this by an alternative
+implementation of @code{make-process} and @code{start-file-process}.
+This is triggered by the connection property
+@t{"direct-async-process"}, @xref{Predefined connection information},
+which must be set to a non-@code{nil} value. Example:
+
+@lisp
+@group
+(add-to-list 'tramp-connection-properties
+ (list (regexp-quote "@trampfn{ssh,user@@host,}")
+ "direct-async-process" t))
+@end group
+@end lisp
+
+However, this approach has different limitations:
+
+@itemize
+@item
+It works only for connection methods defined in @file{tramp-sh.el} and
+@file{tramp-adb.el}.
+
+@item
+It does not support multi-hop methods.
+
+@item
+It does not support interactive user authentication, like password
+handling.
+
+@item
+It does not support a separated error stream.
+
+@item
+It cannot be killed via @code{interrupt-process}.
+
+@item
+It does not report the remote terminal name via @code{process-tty-name}.
+
+@item
+It does not use @code{tramp-remote-path} and
+@code{tramp-remote-process-environment}.
+
+@item
+It does not set environment variable @env{INSIDE_EMACS}.
+@end itemize
+
+In order to gain even more performance, it is recommended to bind
+@code{tramp-verbose} to 0 when running @code{make-process} or
+@code{start-file-process}.
+
+
@node Cleanup remote connections
@section Cleanup remote connections
@cindex cleanup
@@ -4555,9 +4625,8 @@ Abbreviation list expansion can be used to reduce typing
long file names:
@lisp
@group
-(add-to-list
- 'directory-abbrev-alist
- '("^/xy" . "@trampfn{ssh,news@@news.my.domain,/opt/news/etc/}"))
+(add-to-list 'directory-abbrev-alist
+ '("^/xy" . "@trampfn{ssh,news@@news.my.domain,/opt/news/etc/}"))
@end group
@end lisp
diff --git a/etc/MACHINES b/etc/MACHINES
index 1bb244b..78e9cef 100644
--- a/etc/MACHINES
+++ b/etc/MACHINES
@@ -81,25 +81,26 @@ the list at the end of this file.
** Solaris
- On Solaris it is also possible to use either GCC or Solaris Studio
- to build Emacs, by pointing ./configure to the right compiler:
+ On Solaris it is also possible to use either GCC or Oracle Developer
+ Studio to build Emacs, by pointing ./configure to the right compiler:
- ./configure CC='/usr/sfw/bin/gcc' # GCC
- ./configure CC='cc' # Solaris Studio
+ ./configure # Defaults to 'gcc' if available.
+ ./configure CC='cc' # Oracle Developer Studio
- On Solaris, do not use /usr/ucb/cc. Use /opt/SUNWspro/bin/cc. Make
- sure that /usr/ccs/bin and /opt/SUNWspro/bin are in your PATH before
- /usr/ucb. (Most free software packages have the same requirement on
- Solaris.) With this compiler, use '/opt/SUNWspro/bin/cc -E' as the
+ On Solaris, do not use /usr/ucb/cc. Use Oracle Developer Studio.
+ Make sure that /usr/ccs/bin and the Oracle Developer Studio bin
+ directory (e.g., /opt/developerstudio12.6/bin) are in your PATH
+ before /usr/ucb. (Most free software packages have the same
+ requirement on Solaris.) With this compiler, use 'cc -E' as the
preprocessor. If this inserts extra whitespace into its output (see
- the PROBLEMS file) then add the option '-Xs'.
+ the PROBLEMS file), add the option '-Xs'.
To build a 64-bit Emacs (with larger maximum buffer size) on a
- Solaris system which supports 64-bit executables, specify the -m64
+ Solaris system that defaults to 32-bit executables, specify the -m64
compiler option. For example:
- ./configure CC='/usr/sfw/bin/gcc -m64' # GCC
- ./configure CC='cc -m64' # Solaris Studio
+ ./configure CC='gcc -m64' # GCC
+ ./configure CC='cc -m64' # Oracle Developer Studio
* Obsolete platforms
diff --git a/etc/NEWS b/etc/NEWS
index 492d01f..8118272 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -59,6 +59,11 @@ shaping, so 'configure' now recommends that combination.
It was declared obsolete in Emacs 27.1.
---
+** Support for building with '-fcheck-pointer-bounds' has been removed.
+GCC has withdrawn the '-fcheck-pointer-bounds' option and support for
+its implementation has been removed from the Linux kernel.
+
+---
** Emacs no longer supports old OpenBSD systems.
OpenBSD 5.3 and older releases are no longer supported, as they lack
proper pty support that Emacs needs.
@@ -75,6 +80,11 @@ useful on systems such as FreeBSD which ships only with
"etc/termcap".
* Changes in Emacs 28.1
++++
+** The new constants 'shell-command-buffer-name' and
+'shell-command-buffer-name-async' store the default buffer names
+for the output of shell commands.
+
** Support for '(box . SIZE)' 'cursor-type'.
By default, 'box' cursor always has a filled box shape. But if you
specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow
@@ -117,6 +127,11 @@ horizontal movements now stop at the edge of the board.
** Autosaving via 'auto-save-visited-mode' can now be inhibited by
setting the variable 'auto-save-visited-mode' buffer-locally to nil.
+** New commands to describe buttons and widgets have been added.
+'widget-describe' (on a widget) will pop up a help buffer and give a
+description of the properties. Likewise 'button-describe' does the
+same for a button.
+
* Changes in Specialized Modes and Packages in Emacs 28.1
@@ -170,6 +185,11 @@ and variables.
'archive-hideshow-column'. These let you control which columns are
displayed and which are kept hidden.
+---
+*** New command bound to 'C': 'archive-copy-file'
+This command extracts the file under point and writes the data to a
+file.
+
** Emacs Lisp mode
*** The mode-line now indicates whether we're using lexical or dynamic scoping.
@@ -179,6 +199,13 @@ 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
as a data list rather than as a piece of code.
+** Calendar
+
+*** New variable 'calendar-use-numeric-time-zones' to use numeric time zones.
+If non-nil, functions that display time zones (like the 'S' command in
+calendar mode that displays the sunrise time) will display time zones
+like "+0100" instead of "CET".
+
** Dired
*** New user option 'dired-mark-region' affects all Dired commands
@@ -205,6 +232,15 @@ their 'default-directory' under VC.
*** Support for bookmark.el.
Bookmark locations can refer to VC directory buffers.
+---
+*** New user option 'vc-hg-create-bookmark' controls whether a bookmark
+or branch will be created when you invoke 'C-u C-x v s' ('vc-create-tag').
+
+---
+*** 'vc-hg' now uses 'hg summary' command to populate extra 'vc-dir'
+headers.
+
+
** Gnus
---
@@ -223,6 +259,40 @@ The names of the commands 'gnus-slave',
'gnus-slave-no-server' and
*** The 'W Q' summary mode command now takes a numerical prefix to
allow adjusting the fill width.
++++
+*** New variable 'mm-inline-font-lock'.
+This variable is supposed to be bound by callers to determine whether
+inline MIME parts (that support it) are supposed to be font-locked or
+not.
+
+** Message
+
++++
+*** Message now supports the OpenPGP header.
+To generate these headers, add the new function
+'message-add-openpgp-header' to 'message-send-hook'. The header will
+be generated according to the new 'message-openpgp-header' variable.
+
+---
+*** A change to how Mail-Copies-To: never is handled.
+If a user has specified Mail-Copies-To: never, and Message was asked
+to do a "wide reply", some other arbitrary recipient would end up in
+the resulting To header, while the remaining recipients would be put
+in the Cc header. This is somewhat misleading, as it looks like
+you're responding to a specific person in particular. This has been
+changed so that all the recipients are put in the To header in these
+instances.
+
++++
+*** New function to start Emacs in Message mode to send an email.
+Emacs can be defined as a handler for the "x-scheme-handler/mailto"
+MIME type with the following command: "emacs -f message-mailto %u".
+An emacs-mail.desktop file has been included, suitable for installing
+in desktop directories like /usr/share/applications. Clicking on a
+mailto: link in other applications will then open Emacs with headers
+filled out according to the link, e.g.
+"mailto:larsi@gnus.org?subject=This+is+a+test";.
+
---
*** Change to default value of 'message-draft-headers' user option.
The 'Date' symbol has been removed from the default value, meaning that
@@ -231,6 +301,12 @@ was sent. To restore the original behavior of dating a
message
from when it is first saved or delayed, add the symbol 'Date' back to
this user option.
++++
+*** New command to take screenshots.
+In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot')
+command has been added. It depends on using an external program to
+take the actual screenshot, and defaults to ImageMagick "import".
+
** Help
+++
@@ -260,6 +336,10 @@ To revert to the previous behaviour,
unconditionally aborts the current edebug instrumentation with the
supplied error message.
+*** Edebug specification lists can use the new keyword ':unique',
+which appends a unique suffix to the Edebug name of the current
+definition.
+
+++
** ElDoc
@@ -314,6 +394,16 @@ 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.
++++
+*** Support of direct asynchronous process invocation.
+When Tramp connection property "direct-async-process" is set to
+non-nil for a given connection, 'make-process' and 'start-file-process'
+calls are performed directly as in "ssh ... <command>". This avoids
+initialization performance penalties. See the "(tramp) Improving
+performance of asynchronous remote processes" node of the Tramp manual
+for details, and also for a discussion or restrictions. This feature
+is experimental.
+
** Tempo
---
@@ -398,6 +488,14 @@ to substitute spaces in regexp search.
*** The default value of 'hi-lock-highlight-range' was enlarged.
The new default value is 2000000 (2 megabytes).
+** Whitespace mode
+
++++
+*** New style 'missing-newline-at-eof'.
+If present in 'whitespace-style' (as it is by default), the final
+character in the buffer will be highlighted if the buffer doesn't end
+with a newline.
+
** Texinfo
---
@@ -476,6 +574,9 @@ either an internal or external browser.
*** Support for the conkeror browser is now obsolete.
+*** Support for the Mosaic browser has been removed.
+This support has been obsolete since 25.1.
+
** SHR
---
@@ -505,9 +606,24 @@ took more than two seconds to display. The new algorithm
maintains a
decaying average of delays, and if this number gets too high, the
animation is stopped.
++++
+*** The 'n' and 'p' commands (next/previous image) now respects dired order.
+These commands would previously display the next/previous image in
+alphabetical order, but will now find the "parent" dired buffer and
+select the next/previous image file according to how the files are
+sorted there. The commands have also been extended to work when the
+"parent" buffer is an archive mode (i.e., zip file or the like) or tar
+mode buffer.
+
** EWW
+++
+*** New Emacs command line convenience function.
+The 'eww-browse' command has been added, which allows you to register
+Emacs as a MIME handler for "text/x-uri", and will call eww on the
+supplied URL. Usage example: emacs -f eww-browse https://gnu.org
+
++++
*** 'eww-download-directory' will now use the XDG location, if defined.
However, if "~/Downloads/" already exists, that will continue to be
used.
@@ -565,6 +681,12 @@ 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.
+** erc
+
+---
+*** The /ignore command will now ask for a timeout to stop ignoring the user.
+Allowed inputs are seconds or ISO8601-like periods like "1h" or "4h30m".
+
** Battery
---
@@ -601,6 +723,34 @@ custom rules, see the variables
'bug-reference-setup-from-vc-alist',
'bug-reference-setup-from-mail-alist', and
'bug-reference-setup-from-irc-alist'.
+** HTML Mode
+
+---
+*** A new skeleton for adding relative URLs has been added.
+It's bound to the 'C-c C-c f' keystroke, and prompts for a local file
+name.
+
+---
+** Recentf
+The recentf files are no longer backed up.
+
+
+** Miscellaneous
+
+*** The new library hierarchy.el has been added.
+It's a library to create, query, navigate and display hierarchy
+structures.
+
+---
+*** The width of the buffer-name column in 'list-buffers' is now dynamic.
+The width now depends of the width of the window, but will never be
+wider than the length of the longest buffer name, except that it will
+never be narrower than 19 characters.
+
+*** Bookmarks can now be targets for new tabs.
+When the 'bookmark.el' library is loaded, a customize choice is added
+to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list.
+
* New Modes and Packages in Emacs 28.1
@@ -678,6 +828,11 @@ have now been removed.
* Lisp Changes in Emacs 28.1
+---
+** New function 'custom-add-choice'.
+This function can be used by modes to add elements to the
+'choice' customization type of a variable.
+
+++
** New function 'file-modes-number-to-symbolic' to convert a numeric
file mode specification into symbolic form.
@@ -706,6 +861,11 @@ optional argument specifying whether to follow symbolic
links.
** 'parse-time-string' can now parse ISO 8601 format strings,
such as "2020-01-15T16:12:21-08:00".
+---
+** The new function 'decoded-time-period' has been added.
+It interprets a decoded time structure as a period and returns the
+equivalent period in seconds.
+
+++
** The new function 'dom-remove-attribute' has been added.
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index 4ce738d..598a79f 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -2222,6 +2222,7 @@ We list bugs in current versions here. See also the
section on legacy
systems.
*** On Solaris 10, Emacs crashes during the build process.
+(This applies only with './configure --with-unexec=yes', which is rare.)
This was reported for Emacs 25.2 on i386-pc-solaris2.10 with Sun
Studio 12 (Sun C 5.9) and with Oracle Developer Studio 12.6 (Sun C
5.15), and intermittently for sparc-sun-solaris2.10 with Oracle
@@ -2239,66 +2240,6 @@ Solaris. See Bug#26638.
This is a Solaris feature (at least on Intel x86 cpus). Type C-r
C-r C-t, to toggle whether C-x gets through to Emacs.
-*** Problem with remote X server on Suns.
-
-On a Sun, running Emacs on one machine with the X server on another
-may not work if you have used the unshared system libraries. This
-is because the unshared libraries fail to use YP for host name lookup.
-As a result, the host name you specify may not be recognized.
-
-*** Solaris 2.6: Emacs crashes with SIGBUS or SIGSEGV on Solaris after you
delete a frame.
-
-We suspect that this is a bug in the X libraries provided by
-Sun. There is a report that one of these patches fixes the bug and
-makes the problem stop:
-
-105216-01 105393-01 105518-01 105621-01 105665-01 105615-02 105216-02
-105667-01 105401-08 105615-03 105621-02 105686-02 105736-01 105755-03
-106033-01 105379-01 105786-01 105181-04 105379-03 105786-04 105845-01
-105284-05 105669-02 105837-01 105837-02 105558-01 106125-02 105407-01
-
-Another person using a newer system (kernel patch level Generic_105181-06)
-suspects that the bug was fixed by one of these more recent patches:
-
-106040-07 SunOS 5.6: X Input & Output Method patch
-106222-01 OpenWindows 3.6: filemgr (ff.core) fixes
-105284-12 Motif 1.2.7: sparc Runtime library patch
-
-*** Solaris 7 or 8: Emacs reports a BadAtom error (from X)
-
-This happens when Emacs was built on some other version of Solaris.
-Rebuild it on Solaris 8.
-
-*** When using M-x dbx with the SparcWorks debugger, the 'up' and 'down'
-commands do not move the arrow in Emacs.
-
-You can fix this by adding the following line to '~/.dbxinit':
-
- dbxenv output_short_file_name off
-
-*** On Solaris, CTRL-t is ignored by Emacs when you use
-the fr.ISO-8859-15 locale (and maybe other related locales).
-
-You can fix this by editing the file:
-
- /usr/openwin/lib/locale/iso8859-15/Compose
-
-Near the bottom there is a line that reads:
-
- Ctrl<t> <quotedbl> <Y> : "\276" threequarters
-
-while it should read:
-
- Ctrl<T> <quotedbl> <Y> : "\276" threequarters
-
-Note the lower case <t>. Changing this line should make C-t work.
-
-*** On Solaris, Emacs fails to set menu-bar-update-hook on startup, with error
-"Error in menu-bar-update-hook: (error Point before start of properties)".
-This seems to be a GCC optimization bug that occurs for GCC 4.1.2 (-g
-and -g -O2) and GCC 4.2.3 (-g -O and -g -O2). You can fix this by
-compiling with GCC 4.2.3 or CC 5.7, with no optimizations.
-
* Runtime problems specific to MS-Windows
** Emacs on Windows 9X requires UNICOWS.DLL
@@ -2733,13 +2674,13 @@ Libxpm is available for macOS as part of the XQuartz
project.
This indicates a mismatch between the C compiler and preprocessor that
configure is using. For example, on Solaris 10 trying to use
-CC=/opt/SUNWspro/bin/cc (the Sun Studio compiler) together with
-CPP=/usr/ccs/lib/cpp can result in errors of this form (you may also
-see the error '"/usr/include/sys/isa_defs.h", line 500: undefined control').
+CC=/opt/developerstudio12.6/bin/cc (the Oracle Developer Studio
+compiler) together with CPP=/usr/lib/cpp can result in errors of
+this form.
The solution is to tell configure to use the correct C preprocessor
-for your C compiler (CPP="/opt/SUNWspro/bin/cc -E" in the above
-example).
+for your C compiler (CPP="/opt/developerstudio12.6/bin/cc -E" in the
+above example).
** Compilation
@@ -3110,7 +3051,69 @@ This section covers bugs reported on very old hardware
or software.
If you are using hardware and an operating system shipped after 2000,
it is unlikely you will see any of these.
-*** Solaris 2.x
+** Solaris
+
+*** Problem with remote X server on Suns.
+
+On a Sun, running Emacs on one machine with the X server on another
+may not work if you have used the unshared system libraries. This
+is because the unshared libraries fail to use YP for host name lookup.
+As a result, the host name you specify may not be recognized.
+
+*** Solaris 2.6: Emacs crashes with SIGBUS or SIGSEGV on Solaris after you
delete a frame.
+
+We suspect that this is a bug in the X libraries provided by
+Sun. There is a report that one of these patches fixes the bug and
+makes the problem stop:
+
+105216-01 105393-01 105518-01 105621-01 105665-01 105615-02 105216-02
+105667-01 105401-08 105615-03 105621-02 105686-02 105736-01 105755-03
+106033-01 105379-01 105786-01 105181-04 105379-03 105786-04 105845-01
+105284-05 105669-02 105837-01 105837-02 105558-01 106125-02 105407-01
+
+Another person using a newer system (kernel patch level Generic_105181-06)
+suspects that the bug was fixed by one of these more recent patches:
+
+106040-07 SunOS 5.6: X Input & Output Method patch
+106222-01 OpenWindows 3.6: filemgr (ff.core) fixes
+105284-12 Motif 1.2.7: sparc Runtime library patch
+
+*** Solaris 7 or 8: Emacs reports a BadAtom error (from X)
+
+This happens when Emacs was built on some other version of Solaris.
+Rebuild it on Solaris 8.
+
+*** When using M-x dbx with the SparcWorks debugger, the 'up' and 'down'
+commands do not move the arrow in Emacs.
+
+You can fix this by adding the following line to '~/.dbxinit':
+
+ dbxenv output_short_file_name off
+
+*** On Solaris, CTRL-t is ignored by Emacs when you use
+the fr.ISO-8859-15 locale (and maybe other related locales).
+
+You can fix this by editing the file:
+
+ /usr/openwin/lib/locale/iso8859-15/Compose
+
+Near the bottom there is a line that reads:
+
+ Ctrl<t> <quotedbl> <Y> : "\276" threequarters
+
+while it should read:
+
+ Ctrl<T> <quotedbl> <Y> : "\276" threequarters
+
+Note the lower case <t>. Changing this line should make C-t work.
+
+*** On Solaris, Emacs fails to set menu-bar-update-hook on startup, with error
+"Error in menu-bar-update-hook: (error Point before start of properties)".
+This seems to be a GCC optimization bug that occurs for GCC 4.1.2 (-g
+and -g -O2) and GCC 4.2.3 (-g -O and -g -O2). You can fix this by
+compiling with GCC 4.2.3 or CC 5.7, with no optimizations.
+
+*** Other legacy Solaris problems
**** Strange results from format %d in a few cases, on a Sun.
diff --git a/etc/emacs-mail.desktop b/etc/emacs-mail.desktop
new file mode 100644
index 0000000..3a96b9e
--- /dev/null
+++ b/etc/emacs-mail.desktop
@@ -0,0 +1,10 @@
+[Desktop Entry]
+Categories=Network;Email;
+Comment=GNU Emacs is an extensible, customizable text editor - and more
+Exec=emacs -f message-mailto %u
+Icon=emacs
+Name=Emacs (Mail)
+MimeType=x-scheme-handler/mailto;
+NoDisplay=false
+Terminal=false
+Type=Application
diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el
index c298b53..f104c84 100644
--- a/etc/themes/leuven-theme.el
+++ b/etc/themes/leuven-theme.el
@@ -4,7 +4,7 @@
;; Author: Fabrice Niessen <(concat "fniessen" at-sign "pirilampo.org")>
;; URL: https://github.com/fniessen/emacs-leuven-theme
-;; Version: 20200425.0837
+;; Version: 20200513.1928
;; Keywords: color theme
;; This file is part of GNU Emacs.
@@ -31,42 +31,98 @@
;;
;; (load-theme 'leuven t)
;;
-;; Requirements: Emacs 24.
+;; Requirements: Emacs 24+.
+;;
+;; NOTE -- Would you like implement a version of this for dark backgrounds,
+;; please do so! I'm willing to integrate it...
;;; Code:
+;;; Options.
+
+(defgroup leuven nil
+ "Leuven theme options.
+The theme has to be reloaded after changing anything in this group."
+ :group 'faces)
+
+(defcustom leuven-scale-outline-headlines t
+ "Scale `outline' (and `org') level-1 headlines.
+This can be nil for unscaled, t for using the theme default, or a scaling
+number."
+ :type '(choice
+ (const :tag "Unscaled" nil)
+ (const :tag "Default provided by theme" t)
+ (number :tag "Set scaling"))
+ :group 'leuven)
+
+(defcustom leuven-scale-org-agenda-structure t
+ "Scale Org agenda structure lines, like dates.
+This can be nil for unscaled, t for using the theme default, or a scaling
+number."
+ :type '(choice
+ (const :tag "Unscaled" nil)
+ (const :tag "Default provided by theme" t)
+ (number :tag "Set scaling")))
+
+(defun leuven-scale-font (control default-height)
+ "Function for splicing optional font heights into face descriptions.
+CONTROL can be a number, nil, or t. When t, use DEFAULT-HEIGHT."
+ (cond
+ ((numberp control) (list :height control))
+ ((eq t control) (list :height default-height))
+ (t nil)))
+
+;;; Theme Faces.
+
(deftheme leuven
"Face colors with a light background.
-Basic, Font Lock, Isearch, Gnus, Message, Diff, Ediff, Flyspell,
-Semantic, and Ansi-Color faces are included -- and much more...")
+Basic, Font Lock, Isearch, Gnus, Message, Org mode, Diff, Ediff,
+Flyspell, Semantic, and Ansi-Color faces are included -- and much
+more...")
(let ((class '((class color) (min-colors 89)))
- ;; Leuven generic colors
- (cancel '(:slant italic :strike-through t :foreground "gray55"))
+ ;; Leuven generic colors.
+ (cancel '(:slant italic :strike-through t :foreground "#A9A9A9"))
(clock-line '(:box (:line-width 1 :color "#335EA8") :foreground "black"
:background "#EEC900"))
(code-block '(:foreground "#000088" :background "#FFFFE0"))
(code-inline '(:foreground "#006400" :background "#FDFFF7"))
(column '(:height 1.0 :weight normal :slant normal :underline nil
:strike-through nil :foreground "#E6AD4F" :background "#FFF2DE"))
- (diff-added '(:foreground "#008000" :background "#DDFFDD"))
+ (completion-inline '(:weight normal :foreground "#C0C0C0" :inherit
hl-line)) ; Like Google.
+ (completion-other-candidates '(:weight bold :foreground "black"
:background "#EBF4FE"))
+ (completion-selected-candidate '(:weight bold :foreground "white"
:background "#0052A4"))
+ (diff-added '(:background "#DDFFDD"))
(diff-changed '(:foreground "#0000FF" :background "#DDDDFF"))
- (diff-header '(:foreground "#800000" :background "#FFFFAF"))
+ (diff-header '(:weight bold :foreground "#800000" :background "#FFFFAF"))
(diff-hunk-header '(:foreground "#990099" :background "#FFEEFF"))
- (diff-none '(:foreground "gray33"))
- (diff-removed '(:foreground "#A60000" :background "#FFDDDD"))
+ (diff-none '(:foreground "#888888"))
+ (diff-refine-added '(:background "#97F295"))
+ (diff-refine-removed '(:background "#FFB6BA"))
+ (diff-removed '(:background "#FEE8E9"))
(directory '(:weight bold :foreground "blue" :background "#FFFFD2"))
- (highlight-line '(:background "#FFFFD7")) ; #F5F5F5
- (highlight-line-gnus '(:background "#DAEAFC")) ; defined in
`gnus-leuven.el'
+ (file '(:foreground "black"))
+ (function-param '(:foreground "#247284"))
+ (grep-file-name '(:weight bold :foreground "#2A489E")) ; Used for grep
hits.
+ (grep-line-number '(:weight bold :foreground "#A535AE"))
+ (highlight-blue '(:background "#E6ECFF"))
+ (highlight-blue2 '(:background "#E4F1F9"))
+ (highlight-gray '(:background "#E4E4E3"))
+ (highlight-green '(:background "#D5F1CF"))
+ (highlight-red '(:background "#FFC8C8"))
+ (highlight-yellow '(:background "#F6FECD"))
(link '(:weight normal :underline t :foreground "#006DAF"))
+ (link-no-underline '(:weight normal :foreground "#006DAF"))
(mail-header-name '(:family "Sans Serif" :weight normal :foreground
"#A3A3A2"))
(mail-header-other '(:family "Sans Serif" :slant normal :foreground
"#666666"))
- (mail-read '(:weight normal :foreground "#86878B"))
- (mail-ticked '(:weight bold :background "#FBE6EF"))
+ (mail-read '(:foreground "#8C8C8C"))
+ (mail-read-high '(:foreground "#808080"))
+ (mail-ticked '(:foreground "#FF3300"))
(mail-to '(:family "Sans Serif" :underline nil :foreground "#006DAF"))
- (mail-unread '(:weight bold :foreground "black"))
- (marked-line '(:weight bold :foreground "white" :background "red"))
- (match '(:weight bold :background "#FBE448")) ; occur patterns
- (ol1 '(:height 1.3 :weight bold :overline "#A7A7A7" :foreground
"#3C3C3C" :background "#F0F0F0"))
+ (mail-unread '(:weight bold :foreground "#000000"))
+ (mail-unread-high '(:weight bold :foreground "#135985"))
+ (marked-line '(:foreground "#AA0000" :background "#FFAAAA"))
+ (match '(:weight bold :background "#FFFF00")) ; occur patterns + match
in helm for files + match in Org files.
+ (ol1 `(,@(leuven-scale-font leuven-scale-outline-headlines 1.3) :weight
bold :overline "#A7A7A7" :foreground "#3C3C3C" :background "#F0F0F0"))
(ol2 '(:height 1.0 :weight bold :overline "#123555" :foreground
"#123555" :background "#E5F4FB"))
(ol3 '(:height 1.0 :weight bold :foreground "#005522" :background
"#EFFFEF"))
(ol4 '(:height 1.0 :weight bold :slant normal :foreground "#EA6300"))
@@ -74,15 +130,22 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
(ol6 '(:height 1.0 :weight bold :slant italic :foreground "#0077CC"))
(ol7 '(:height 1.0 :weight bold :slant italic :foreground "#2EAE2C"))
(ol8 '(:height 1.0 :weight bold :slant italic :foreground "#FD8008"))
- (paren-matched '(:background "#99CCFF"))
- (paren-unmatched '(:underline "red" :foreground nil :background
"#FFDCDC"))
- (region '(:background "#ABDFFA"))
+ (paren-matched '(:background "#C0E8C3")) ; Or take that green for region?
+ (paren-unmatched '(:weight bold :underline "red" :foreground "black"
:background "#FFA5A5"))
+ (region '(:background "#8ED3FF"))
(shadow '(:foreground "#7F7F7F"))
(string '(:foreground "#008000")) ; or #D0372D
(subject '(:family "Sans Serif" :weight bold :foreground "black"))
- (symlink '(:foreground "deep sky blue"))
- (volatile-highlight '(:underline nil :background "#FFF876"))
- (vc-branch '(:box (:line-width 1 :color "#00CC33") :foreground "black"
:background "#AAFFAA")))
+ (symlink '(:foreground "#1F8DD6"))
+ (tab '(:foreground "#E8E8E8" :background "white"))
+ (trailing '(:foreground "#E8E8E8" :background "#FFFFAB"))
+ (volatile-highlight '(:underline nil :foreground "white" :background
"#9E3699"))
+ (volatile-highlight-supersize '(:height 1.1 :underline nil :foreground
"white" :background "#9E3699")) ; flash-region
+ (vc-branch '(:box (:line-width 1 :color "#00CC33") :foreground "black"
:background "#AAFFAA"))
+ (xml-attribute '(:foreground "#F36335"))
+ (xml-tag '(:foreground "#AE1B9A"))
+ (highlight-current-tag '(:background "#E8E8FF")) ; #EEF3F6 or #FFEB26
+ )
(custom-theme-set-faces
'leuven
@@ -91,40 +154,43 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(bold-italic ((,class (:weight bold :slant italic :foreground "black"))))
`(italic ((,class (:slant italic :foreground "#1A1A1A"))))
`(underline ((,class (:underline t))))
- `(cursor ((,class (:background "#0FB300"))))
+ `(cursor ((,class (:background "#21BDFF"))))
+
+ ;; Lucid toolkit emacs menus.
+ `(menu ((,class (:foreground "#FFFFFF" :background "#333333"))))
- ;; Highlighting faces
- `(fringe ((,class (:foreground "#9B9B9B" :background "#EDEDED"))))
- `(highlight ((,class ,volatile-highlight)))
+ ;; Highlighting faces.
+ `(fringe ((,class (:foreground "#4C9ED9" :background "white"))))
+ `(highlight ((,class ,highlight-blue)))
`(region ((,class ,region)))
- `(secondary-selection ((,class ,match))) ; used by Org-mode for
highlighting matched entries and keywords
- `(isearch ((,class (:weight bold :underline "#FF9632" :foreground nil
:background "#FDBD33"))))
- `(isearch-fail ((,class (:weight bold :foreground "black" :background
"#FF9999"))))
- `(lazy-highlight ((,class (:underline "#FF9632" :background "#FFFF00")))) ;
isearch others
- `(trailing-whitespace ((,class (:background "#FFFF57"))))
- `(whitespace-hspace ((,class (:foreground "#D2D2D2"))))
- `(whitespace-indentation ((,class (:foreground "#A1A1A1" :background
"white"))))
+ `(secondary-selection ((,class ,match))) ; Used by Org-mode for
highlighting matched entries and keywords.
+ `(isearch ((,class (:underline "black" :foreground "white" :background
"#5974AB"))))
+ `(isearch-fail ((,class (:weight bold :foreground "black" :background
"#FFCCCC"))))
+ `(lazy-highlight ((,class (:foreground "black" :background "#FFFF00")))) ;
Isearch others (see `match').
+ `(trailing-whitespace ((,class ,trailing)))
+ `(query-replace ((,class (:inherit isearch))))
+ `(whitespace-hspace ((,class (:foreground "#D2D2D2")))) ; see also
`nobreak-space'
+ `(whitespace-indentation ((,class ,tab)))
`(whitespace-line ((,class (:foreground "#CC0000" :background "#FFFF88"))))
- `(whitespace-tab ((,class (:foreground "#A1A1A1" :background "white"))))
- `(whitespace-trailing ((,class (:foreground "#B3B3B3" :background
"#FFFF57"))))
+ `(whitespace-tab ((,class ,tab)))
+ `(whitespace-trailing ((,class ,trailing)))
- ;; Mode line faces
+ ;; Mode line faces.
`(mode-line ((,class (:box (:line-width 1 :color "#1A2F54") :foreground
"#85CEEB" :background "#335EA8"))))
`(mode-line-inactive ((,class (:box (:line-width 1 :color "#4E4E4C")
:foreground "#F0F0EF" :background "#9B9C97"))))
`(mode-line-buffer-id ((,class (:weight bold :foreground "white"))))
`(mode-line-emphasis ((,class (:weight bold :foreground "white"))))
`(mode-line-highlight ((,class (:foreground "yellow"))))
- ;; Escape and prompt faces
+ ;; Escape and prompt faces.
`(minibuffer-prompt ((,class (:weight bold :foreground "black" :background
"gold"))))
`(minibuffer-noticeable-prompt ((,class (:weight bold :foreground "black"
:background "gold"))))
`(escape-glyph ((,class (:foreground "#008ED1"))))
- `(homoglyph ((,class (:foreground "#008ED1"))))
`(error ((,class (:foreground "red"))))
`(warning ((,class (:weight bold :foreground "orange"))))
`(success ((,class (:foreground "green"))))
- ;; Font lock faces
+ ;; Font lock faces.
`(font-lock-builtin-face ((,class (:foreground "#006FE0"))))
`(font-lock-comment-delimiter-face ((,class (:foreground "#8D8D84")))) ;
#696969
`(font-lock-comment-face ((,class (:slant italic :foreground "#8D8D84"))))
; #696969
@@ -140,32 +206,32 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(font-lock-variable-name-face ((,class (:weight normal :foreground
"#BA36A5")))) ; #800080
`(font-lock-warning-face ((,class (:weight bold :foreground "red"))))
- ;; Button and link faces
+ ;; Button and link faces.
`(link ((,class ,link)))
`(link-visited ((,class (:underline t :foreground "#E5786D"))))
`(button ((,class (:underline t :foreground "#006DAF"))))
- `(header-line ((,class (:weight bold :underline "black" :overline "black"
:foreground "black" :background "#FFFF88"))))
+ `(header-line ((,class (:box (:line-width 1 :color "black") :foreground
"black" :background "#F0F0F0"))))
- ;; Gnus faces
+ ;; Gnus faces.
`(gnus-button ((,class (:weight normal))))
`(gnus-cite-attribution-face ((,class (:foreground "#5050B0"))))
- `(gnus-cite-face-1 ((,class (:foreground "#5050B0"))))
- `(gnus-cite-face-10 ((,class (:foreground "#990000"))))
- `(gnus-cite-face-2 ((,class (:foreground "#660066"))))
- `(gnus-cite-face-3 ((,class (:foreground "#007777"))))
- `(gnus-cite-face-4 ((,class (:foreground "#990000"))))
- `(gnus-cite-face-5 ((,class (:foreground "#000099"))))
- `(gnus-cite-face-6 ((,class (:foreground "#BB6600"))))
- `(gnus-cite-face-7 ((,class (:foreground "#5050B0"))))
- `(gnus-cite-face-8 ((,class (:foreground "#660066"))))
- `(gnus-cite-face-9 ((,class (:foreground "#007777"))))
+ `(gnus-cite-1 ((,class (:foreground "#5050B0" :background "#F6F6F6"))))
+ `(gnus-cite-2 ((,class (:foreground "#660066" :background "#F6F6F6"))))
+ `(gnus-cite-3 ((,class (:foreground "#007777" :background "#F6F6F6"))))
+ `(gnus-cite-4 ((,class (:foreground "#990000" :background "#F6F6F6"))))
+ `(gnus-cite-5 ((,class (:foreground "#000099" :background "#F6F6F6"))))
+ `(gnus-cite-6 ((,class (:foreground "#BB6600" :background "#F6F6F6"))))
+ `(gnus-cite-7 ((,class (:foreground "#5050B0" :background "#F6F6F6"))))
+ `(gnus-cite-8 ((,class (:foreground "#660066" :background "#F6F6F6"))))
+ `(gnus-cite-9 ((,class (:foreground "#007777" :background "#F6F6F6"))))
+ `(gnus-cite-10 ((,class (:foreground "#990000" :background "#F6F6F6"))))
`(gnus-emphasis-bold ((,class (:weight bold))))
`(gnus-emphasis-highlight-words ((,class (:foreground "yellow" :background
"black"))))
`(gnus-group-mail-1 ((,class (:weight bold :foreground "#FF50B0"))))
`(gnus-group-mail-1-empty ((,class (:foreground "#5050B0"))))
`(gnus-group-mail-2 ((,class (:weight bold :foreground "#FF0066"))))
`(gnus-group-mail-2-empty ((,class (:foreground "#660066"))))
- `(gnus-group-mail-3 ((,class (:weight bold :foreground "black"))))
+ `(gnus-group-mail-3 ((,class ,mail-unread)))
`(gnus-group-mail-3-empty ((,class ,mail-read)))
`(gnus-group-mail-low ((,class ,cancel)))
`(gnus-group-mail-low-empty ((,class ,cancel)))
@@ -173,8 +239,8 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(gnus-group-news-1-empty ((,class (:foreground "#5050B0"))))
`(gnus-group-news-2 ((,class (:weight bold :foreground "#FF0066"))))
`(gnus-group-news-2-empty ((,class (:foreground "#660066"))))
- `(gnus-group-news-3 ((,class (:weight bold :foreground "black"))))
- `(gnus-group-news-3-empty ((,class (:foreground "#808080"))))
+ `(gnus-group-news-3 ((,class ,mail-unread)))
+ `(gnus-group-news-3-empty ((,class ,mail-read)))
`(gnus-group-news-4 ((,class (:weight bold :foreground "#FF0000"))))
`(gnus-group-news-4-empty ((,class (:foreground "#990000"))))
`(gnus-group-news-5 ((,class (:weight bold :foreground "#FF0099"))))
@@ -194,11 +260,11 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(gnus-signature ((,class (:slant italic :foreground "#8B8D8E"))))
`(gnus-splash ((,class (:foreground "#FF8C00"))))
`(gnus-summary-cancelled ((,class ,cancel)))
- `(gnus-summary-high-ancient ((,class (:weight normal :foreground "#808080"
:background "#FFFFE6"))))
- `(gnus-summary-high-read ((,class (:weight normal :foreground "#999999"
:background "#FFFFE6"))))
+ `(gnus-summary-high-ancient ((,class ,mail-unread-high)))
+ `(gnus-summary-high-read ((,class ,mail-read-high)))
`(gnus-summary-high-ticked ((,class ,mail-ticked)))
- `(gnus-summary-high-unread ((,class (:weight bold :foreground "black"
:background "#FFFFCC"))))
- `(gnus-summary-low-ancient ((,class (:slant italic :foreground "gray55"))))
+ `(gnus-summary-high-unread ((,class ,mail-unread-high)))
+ `(gnus-summary-low-ancient ((,class (:slant italic :foreground "black"))))
`(gnus-summary-low-read ((,class (:slant italic :foreground "#999999"
:background "#E0E0E0"))))
`(gnus-summary-low-ticked ((,class ,mail-ticked)))
`(gnus-summary-low-unread ((,class (:slant italic :foreground "black"))))
@@ -209,82 +275,105 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(gnus-summary-selected ((,class (:foreground "white" :background
"#008CD7"))))
`(gnus-x-face ((,class (:foreground "black" :background "white"))))
- ;; Message faces
+ ;; Message faces.
`(message-header-name ((,class ,mail-header-name)))
`(message-header-cc ((,class ,mail-to)))
`(message-header-other ((,class ,mail-header-other)))
`(message-header-subject ((,class ,subject)))
`(message-header-to ((,class ,mail-to)))
- `(message-cited-text ((,class (:foreground "#5050B0"))))
+ `(message-cited-text ((,class (:foreground "#5050B0" :background
"#F6F6F6"))))
`(message-separator ((,class (:family "Sans Serif" :weight normal
:foreground "#BDC2C6"))))
`(message-header-newsgroups ((,class (:family "Sans Serif" :foreground
"#3399CC"))))
`(message-header-xheader ((,class ,mail-header-other)))
`(message-mml ((,class (:foreground "forest green"))))
- ;; Diff
+ ;; Diff.
`(diff-added ((,class ,diff-added)))
`(diff-changed ((,class ,diff-changed)))
`(diff-context ((,class ,diff-none)))
`(diff-file-header ((,class ,diff-header)))
`(diff-file1-hunk-header ((,class (:foreground "dark magenta" :background
"#EAF2F5"))))
`(diff-file2-hunk-header ((,class (:foreground "#2B7E2A" :background
"#EAF2F5"))))
- `(diff-function ((,class (:foreground "darkgray"))))
+ `(diff-function ((,class (:foreground "#CC99CC"))))
`(diff-header ((,class ,diff-header)))
`(diff-hunk-header ((,class ,diff-hunk-header)))
`(diff-index ((,class ,diff-header)))
- `(diff-indicator-added ((,class (:background "#AAFFAA"))))
- `(diff-indicator-changed ((,class (:background "#8080FF"))))
- `(diff-indicator-removed ((,class (:background "#FFBBBB"))))
+ `(diff-indicator-added ((,class (:foreground "#3A993A" :background
"#CDFFD8"))))
+ `(diff-indicator-changed ((,class (:background "#DBEDFF"))))
+ `(diff-indicator-removed ((,class (:foreground "#CC3333" :background
"#FFDCE0"))))
+ `(diff-refine-added ((,class ,diff-refine-added)))
`(diff-refine-change ((,class (:background "#DDDDFF"))))
+ `(diff-refine-removed ((,class ,diff-refine-removed)))
`(diff-removed ((,class ,diff-removed)))
- ;; SMerge
+ ;; SMerge.
+ `(smerge-mine ((,class ,diff-changed)))
+ `(smerge-other ((,class ,diff-added)))
+ `(smerge-base ((,class ,diff-removed)))
+ `(smerge-markers ((,class (:background "#FFE5CC"))))
`(smerge-refined-change ((,class (:background "#AAAAFF"))))
- ;; Ediff
- `(ediff-current-diff-A ((,class (:foreground "gray33" :background
"#FFDDDD"))))
- `(ediff-current-diff-B ((,class (:foreground "gray33" :background
"#DDFFDD"))))
- `(ediff-current-diff-C ((,class (:foreground "black" :background "cyan"))))
- `(ediff-even-diff-A ((,class (:foreground "black" :background "light
grey"))))
- `(ediff-even-diff-B ((,class (:foreground "black" :background "light
grey"))))
- `(ediff-fine-diff-A ((,class (:foreground "#A60000" :background
"#FFAAAA"))))
- `(ediff-fine-diff-B ((,class (:foreground "#008000" :background
"#55FF55"))))
- `(ediff-odd-diff-A ((,class (:foreground "black" :background "light
grey"))))
- `(ediff-odd-diff-B ((,class (:foreground "black" :background "light
grey"))))
-
- ;; Flyspell
-;; (when (version< emacs-version "24.XXX")
- `(flyspell-duplicate ((,class (:underline "#008000" :inherit nil))))
- `(flyspell-incorrect ((,class (:underline "red" :inherit nil))))
-;; `(flyspell-duplicate ((,class (:underline (:style wave :color "#008000")
:inherit nil))))
-;; `(flyspell-incorrect ((,class (:underline (:style wave :color "red")
:inherit nil))))
-
- ;; ;; Semantic faces
+ ;; Ediff.
+ `(ediff-current-diff-A ((,class (:background "#FFDDDD"))))
+ `(ediff-current-diff-B ((,class (:background "#DDFFDD"))))
+ `(ediff-current-diff-C ((,class (:background "cyan"))))
+ `(ediff-even-diff-A ((,class (:background "light grey"))))
+ `(ediff-even-diff-B ((,class (:background "light grey"))))
+ `(ediff-fine-diff-A ((,class (:background "#FFAAAA"))))
+ `(ediff-fine-diff-B ((,class (:background "#55FF55"))))
+ `(ediff-odd-diff-A ((,class (:background "light grey"))))
+ `(ediff-odd-diff-B ((,class (:background "light grey"))))
+
+ ;; Flyspell.
+ (if (version< emacs-version "24.4")
+ `(flyspell-duplicate ((,class (:underline "#F4EB80" :inherit nil))))
+ `(flyspell-duplicate ((,class (:underline (:style wave :color "#F4EB80")
:background "#FAF7CC" :inherit nil)))))
+ (if (version< emacs-version "24.4")
+ `(flyspell-incorrect ((,class (:underline "#FAA7A5" :inherit nil))))
+ `(flyspell-incorrect ((,class (:underline (:style wave :color "#FAA7A5")
:background "#F4D7DA":inherit nil)))))
+
+ ;; ;; Semantic faces.
;; `(semantic-decoration-on-includes ((,class (:underline ,cham-4))))
;; `(semantic-decoration-on-private-members-face ((,class (:background
,alum-2))))
;; `(semantic-decoration-on-protected-members-face ((,class (:background
,alum-2))))
- ;; `(semantic-decoration-on-unknown-includes ((,class (:background
,choc-3))))
+ `(semantic-decoration-on-unknown-includes ((,class (:background
"#FFF8F8"))))
;; `(semantic-decoration-on-unparsed-includes ((,class (:underline
,orange-3))))
- ;; `(semantic-tag-boundary-face ((,class (:overline ,blue-1))))
+ `(semantic-highlight-func-current-tag-face ((,class
,highlight-current-tag)))
+ `(semantic-tag-boundary-face ((,class (:overline "#777777")))) ; Method
separator.
;; `(semantic-unmatched-syntax-face ((,class (:underline ,red-1))))
`(Info-title-1-face ((,class ,ol1)))
`(Info-title-2-face ((,class ,ol2)))
`(Info-title-3-face ((,class ,ol3)))
`(Info-title-4-face ((,class ,ol4)))
- `(ac-completion-face ((,class (:underline nil :foreground "#C0C0C0")))) ;
like Google
- `(ace-jump-face-foreground ((,class (:foreground "black" :background
"#FBE448"))))
+ `(ace-jump-face-foreground ((,class (:weight bold :foreground "black"
:background "#FEA500"))))
+ `(ahs-face ((,class (:background "#E4E4FF"))))
+ `(ahs-definition-face ((,class (:background "#FFB6C6"))))
+ `(ahs-plugin-defalt-face ((,class (:background "#FFE4FF")))) ; Current.
+ `(anzu-match-1 ((,class (:foreground "black" :background "aquamarine"))))
+ `(anzu-match-2 ((,class (:foreground "black" :background "springgreen"))))
+ `(anzu-match-3 ((,class (:foreground "black" :background "red"))))
+ `(anzu-mode-line ((,class (:foreground "black" :background "#80FF80"))))
+ `(anzu-mode-line-no-match ((,class (:foreground "black" :background
"#FF8080"))))
+ `(anzu-replace-highlight ((,class (:inherit query-replace))))
+ `(anzu-replace-to ((,class (:weight bold :foreground "#BD33FD" :background
"#FDBD33"))))
`(auto-dim-other-buffers-face ((,class (:background "#F7F7F7"))))
+ `(avy-background-face ((,class (:background "#A9A9A9"))))
+ `(avy-lead-face ((,class (:weight bold :foreground "black" :background
"#FEA500"))))
`(bbdb-company ((,class (:slant italic :foreground "steel blue"))))
`(bbdb-field-name ((,class (:weight bold :foreground "steel blue"))))
`(bbdb-field-value ((,class (:foreground "steel blue"))))
`(bbdb-name ((,class (:underline t :foreground "#FF6633"))))
- `(bmkp-light-autonamed ((,class (:background "#C2DDFD"))))
- `(bmkp-light-fringe-autonamed ((,class (:background "#90AFD5"))))
- `(bmkp-light-fringe-non-autonamed ((,class (:background "#D5FFD5"))))
- `(bmkp-light-non-autonamed ((,class (:background "#C4FFC4"))))
- `(browse-kill-ring-separator-face ((,class (:weight bold :foreground "slate
gray"))))
+ `(bmkp-light-autonamed ((,class (:background "#F0F0F0"))))
+ `(bmkp-light-fringe-autonamed ((,class (:foreground "#5A5A5A" :background
"#D4D4D4"))))
+ `(bmkp-light-fringe-non-autonamed ((,class (:foreground "#FFFFCC"
:background "#01FFFB")))) ; default
+ `(bmkp-light-non-autonamed ((,class (:background "#BFFFFE"))))
+ `(bmkp-no-local ((,class (:background "pink"))))
+ `(browse-kill-ring-separator-face ((,class (:foreground "red"))))
+ `(calendar-month-header ((,class (:weight bold :foreground "#4F4A3D"
:background "#FFFFCC"))))
`(calendar-today ((,class (:weight bold :foreground "#4F4A3D" :background
"#FFFFCC"))))
+ `(calendar-weekday-header ((,class (:weight bold :foreground "#1662AF"))))
+ `(calendar-weekend-header ((,class (:weight bold :foreground "#4E4E4E"))))
`(cfw:face-annotation ((,class (:foreground "green" :background "red"))))
`(cfw:face-day-title ((,class (:foreground "#C9C9C9"))))
`(cfw:face-default-content ((,class (:foreground "#2952A3"))))
@@ -299,12 +388,14 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(cfw:face-sunday ((,class (:foreground "#4E4E4E" :background "white"
:weight bold))))
`(cfw:face-title ((,class (:height 2.0 :foreground "#676767" :weight bold
:inherit variable-pitch))))
`(cfw:face-today ((,class (:foreground "#4F4A3D" :background "#FFFFCC"))))
- `(cfw:face-today-title ((,class (:foreground "#4A95EB" :background
"#FFFFCC"))))
+ `(cfw:face-today-title ((,class (:foreground "white" :background
"#1766B1"))))
`(cfw:face-toolbar ((,class (:background "white"))))
`(cfw:face-toolbar-button-off ((,class (:foreground "#CFCFCF" :background
"white"))))
`(cfw:face-toolbar-button-on ((,class (:foreground "#5E5E5E" :background
"#F6F6F6"))))
- `(change-log-date-face ((,class (:foreground "purple"))))
+ `(change-log-date ((,class (:foreground "purple"))))
`(change-log-file ((,class (:weight bold :foreground "#4183C4"))))
+ `(change-log-list ((,class (:foreground "black" :background "#75EEC7"))))
+ `(change-log-name ((,class (:foreground "#008000"))))
`(circe-highlight-all-nicks-face ((,class (:foreground "blue" :background
"#F0F0F0")))) ; other nick names
`(circe-highlight-nick-face ((,class (:foreground "#009300" :background
"#F0F0F0")))) ; messages with my nick cited
`(circe-my-message-face ((,class (:foreground "#8B8B8B" :background
"#F0F0F0"))))
@@ -314,15 +405,38 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(comint-highlight-input ((,class (:weight bold :foreground "#0000FF"
:inherit nil))))
;; `(comint-highlight-prompt ((,class (:weight bold :foreground "black"
:background "gold"))))
`(comint-highlight-prompt ((,class (:weight bold :foreground "#0000FF"
:inherit nil))))
- `(company-preview-common ((,class (:foreground "#C0C0C0" :background
"#FFFFD7")))) ; same background as highlight-line
- `(company-tooltip-annotation ((,class (:foreground "#999999" :background
"cornsilk"))))
- `(company-tooltip-common ((,class (:weight bold :inherit company-tooltip))))
- `(company-tooltip-common-selection ((,class (:weight bold :inherit
company-tooltip-selection))))
+
+ ;; `(ac-selection-face ((,class ,completion-selected-candidate)))
+ `(ac-selection-face ((,class (:weight bold :foreground "white" :background
"orange")))) ; TEMP For diff'ing AC from Comp.
+ `(ac-candidate-face ((,class ,completion-other-candidates)))
+ `(ac-completion-face ((,class ,completion-inline)))
+ `(ac-candidate-mouse-face ((,class (:inherit highlight))))
+ `(popup-scroll-bar-background-face ((,class (:background "#EBF4FE"))))
+ `(popup-scroll-bar-foreground-face ((,class (:background "#D1DAE4")))) ;
Scrollbar (visible).
+
+ `(company-tooltip-common-selection ((,class (:weight normal :foreground
"#F9ECCC" :inherit company-tooltip-selection)))) ; Prefix + common part in
tooltip (for selection).
+ `(company-tooltip-selection ((,class ,completion-selected-candidate))) ;
Suffix in tooltip (for selection).
+ `(company-tooltip-annotation-selection ((,class (:weight normal :foreground
"#F9ECCC")))) ; Annotation (for selection).
+
+ `(company-tooltip-common ((,class (:weight normal :foreground "#B000B0"
:inherit company-tooltip)))) ; Prefix + common part in tooltip.
+ `(company-tooltip ((,class ,completion-other-candidates))) ; Suffix in
tooltip.
+ `(company-tooltip-annotation ((,class (:weight normal :foreground
"#2415FF")))) ; Annotation.
+
+ `(company-preview-common ((,class ,completion-inline)))
+
+ `(company-scrollbar-bg ((,class (:background "#EBF4FE"))))
+ `(company-scrollbar-fg ((,class (:background "#D1DAE4")))) ; Scrollbar
(visible).
+
`(compare-windows ((,class (:background "#FFFF00"))))
- `(compilation-error ((,class (:weight bold :foreground "red"))))
- `(compilation-info ((,class (:weight bold :foreground "#2A489E")))) ; used
for grep
- `(compilation-line-number ((,class (:weight bold :foreground "#A535AE"))))
+ ;; `(completions-common-part ((,class (:foreground "red" :weight bold))))
+ ;; `(completions-first-difference ((,class (:foreground "green" :weight
bold))))
+ `(compilation-error ((,class (:weight bold :foreground "red")))) ; Used for
grep error messages.
+ `(compilation-info ((,class (:weight bold :foreground "#6784d7"))))
+ `(compilation-line-number ((,class ,grep-line-number)))
`(compilation-warning ((,class (:weight bold :foreground "orange"))))
+ `(compilation-mode-line-exit ((,class (:weight bold :foreground "green"))))
; :exit[matched]
+ `(compilation-mode-line-fail ((,class (:weight bold :foreground
"violet")))) ; :exit[no match]
+ `(compilation-mode-line-run ((,class (:weight bold :foreground "orange"))))
; :run
`(css-property ((,class (:foreground "#00AA00"))))
`(css-selector ((,class (:weight bold :foreground "blue"))))
`(custom-button ((,class (:box (:line-width 2 :style released-button)
:foreground "black" :background "lightgrey"))))
@@ -348,11 +462,14 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(custom-variable-button ((,class (:weight bold :underline t))))
`(custom-variable-tag ((,class (:family "Sans Serif" :height 1.2 :weight
bold :foreground "blue1"))))
`(custom-visibility ((,class ,link)))
- `(diff-hl-change ((,class (:foreground "blue3" :inherit diff-changed))))
- `(diff-hl-delete ((,class (:foreground "red3" :inherit diff-removed))))
- `(diff-hl-dired-change ((,class (:background "#FFA335" :foreground "black"
:weight bold))))
+ `(diff-hl-change ((,class (:foreground "blue3" :background "#DBEDFF"))))
+ `(diff-hl-delete ((,class (:foreground "red3" :background "#FFDCE0"))))
+ `(diff-hl-dired-change ((,class (:weight bold :foreground "black"
:background "#FFA335"))))
+ `(diff-hl-dired-delete ((,class (:weight bold :foreground "#D73915"))))
+ `(diff-hl-dired-ignored ((,class (:weight bold :foreground "white"
:background "#C0BBAB"))))
+ `(diff-hl-dired-insert ((,class (:weight bold :foreground "#B9B9BA"))))
`(diff-hl-dired-unknown ((,class (:foreground "white" :background
"#3F3BB4"))))
- `(diff-hl-insert ((,class (:foreground "green4" :inherit diff-added))))
+ `(diff-hl-insert ((,class (:foreground "green4" :background "#CDFFD8"))))
`(diff-hl-unknown ((,class (:foreground "white" :background "#3F3BB4"))))
`(diary-face ((,class (:foreground "#87C9FC"))))
`(dircolors-face-asm ((,class (:foreground "black"))))
@@ -385,17 +502,36 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(diredp-compressed-file-suffix ((,class (:foreground "red"))))
`(diredp-date-time ((,class (:foreground "purple"))))
`(diredp-dir-heading ((,class ,directory)))
+ `(diredp-dir-name ((,class ,directory)))
`(diredp-dir-priv ((,class ,directory)))
`(diredp-exec-priv ((,class (:background "#03C03C"))))
`(diredp-executable-tag ((,class (:foreground "ForestGreen" :background
"white"))))
- `(diredp-file-name ((,class (:foreground "black"))))
+ `(diredp-file-name ((,class ,file)))
`(diredp-file-suffix ((,class (:foreground "#C0C0C0"))))
`(diredp-flag-mark-line ((,class ,marked-line)))
`(diredp-ignored-file-name ((,class ,shadow)))
`(diredp-read-priv ((,class (:background "#0A99FF"))))
`(diredp-write-priv ((,class (:foreground "white" :background "#FF4040"))))
+ `(eldoc-highlight-function-argument ((,class (:weight bold :foreground
"red" :background "#FFE4FF"))))
+ `(elfeed-search-filter-face ((,class (:foreground "gray"))))
+ ;; `(eww-form-checkbox ((,class ())))
+ ;; `(eww-form-select ((,class ())))
+ ;; `(eww-form-submit ((,class ())))
+ `(eww-form-text ((,class (:weight bold :foreground "#40586F" :background
"#A7CDF1"))))
+ ;; `(eww-form-textarea ((,class ())))
`(file-name-shadow ((,class ,shadow)))
+ `(flycheck-error ((,class (:underline (:color "#FE251E" :style wave)
:weight bold :background "#FFE1E1"))))
+ `(flycheck-error-list-line-number ((,class (:foreground "#A535AE"))))
+ `(flycheck-fringe-error ((,class (:foreground "#FE251E"))))
+ `(flycheck-fringe-info ((,class (:foreground "#158A15"))))
+ `(flycheck-fringe-warning ((,class (:foreground "#F4A939"))))
+ `(flycheck-info ((,class (:underline (:color "#158A15" :style wave) :weight
bold))))
+ `(flycheck-warning ((,class (:underline (:color "#F4A939" :style wave)
:weight bold :background "#FFFFBE"))))
`(font-latex-bold-face ((,class (:weight bold :foreground "black"))))
+ `(fancy-narrow-blocked-face ((,class (:foreground "#9998A4"))))
+ `(flycheck-color-mode-line-error-face ((, class (:background "#CF5B56"))))
+ `(flycheck-color-mode-line-warning-face ((, class (:background "#EBC700"))))
+ `(flycheck-color-mode-line-info-face ((, class (:background "yellow"))))
`(font-latex-italic-face ((,class (:slant italic :foreground "#1A1A1A"))))
`(font-latex-math-face ((,class (:foreground "blue"))))
`(font-latex-sectioning-1-face ((,class (:family "Sans Serif" :height 2.7
:weight bold :foreground "cornflower blue"))))
@@ -408,36 +544,65 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(font-latex-verbatim-face ((,class (:foreground "#000088" :background
"#FFFFE0" :inherit nil))))
`(git-commit-summary-face ((,class (:foreground "#000000"))))
`(git-commit-comment-face ((,class (:slant italic :foreground "#696969"))))
+ `(git-timemachine-commit ((,class ,diff-removed)))
+ `(git-timemachine-minibuffer-author-face ((,class ,diff-added)))
+ `(git-timemachine-minibuffer-detail-face ((,class ,diff-header)))
+ `(google-translate-text-face ((,class (:foreground "#777777" :background
"#F5F5F5"))))
+ `(google-translate-phonetic-face ((,class (:inherit shadow))))
+ `(google-translate-translation-face ((,class (:weight normal :foreground
"#3079ED" :background "#E3EAF2"))))
+ `(google-translate-suggestion-label-face ((,class (:foreground "red"))))
+ `(google-translate-suggestion-face ((,class (:slant italic :underline t))))
+ `(google-translate-listen-button-face ((,class (:height 0.8))))
`(helm-action ((,class (:foreground "black"))))
+ `(helm-bookmark-file ((,class ,file)))
`(helm-bookmarks-su-face ((,class (:foreground "red"))))
+ `(helm-buffer-directory ((,class ,directory)))
+ ;; `(helm-non-file-buffer ((,class (:slant italic :foreground "blue"))))
+ ;; `(helm-buffer-file ((,class (:foreground "#333333"))))
+ `(helm-buffer-modified ((,class (:slant italic :foreground "#BA36A5"))))
`(helm-buffer-process ((,class (:foreground "#008200"))))
`(helm-candidate-number ((,class (:foreground "black" :background
"#FFFF66"))))
`(helm-dir-heading ((,class (:foreground "blue" :background "pink"))))
`(helm-dir-priv ((,class (:foreground "dark red" :background "light
grey"))))
`(helm-ff-directory ((,class ,directory)))
+ `(helm-ff-dotted-directory ((,class ,directory)))
`(helm-ff-executable ((,class (:foreground "green3" :background "white"))))
`(helm-ff-file ((,class (:foreground "black"))))
`(helm-ff-invalid-symlink ((,class (:foreground "yellow" :background
"red"))))
`(helm-ff-symlink ((,class ,symlink)))
`(helm-file-name ((,class (:foreground "blue"))))
`(helm-gentoo-match-face ((,class (:foreground "red"))))
+ `(helm-grep-file ((,class ,grep-file-name)))
+ `(helm-grep-lineno ((,class ,grep-line-number)))
`(helm-grep-match ((,class ,match)))
`(helm-grep-running ((,class (:weight bold :foreground "white"))))
- `(helm-grep-lineno ((,class ,shadow)))
`(helm-isearch-match ((,class (:background "#CCFFCC"))))
+ `(helm-lisp-show-completion ((,class ,volatile-highlight-supersize))) ; See
`helm-dabbrev'.
+ ;; `(helm-ls-git-added-copied-face ((,class (:foreground ""))))
+ ;; `(helm-ls-git-added-modified-face ((,class (:foreground ""))))
+ ;; `(helm-ls-git-conflict-face ((,class (:foreground ""))))
+ ;; `(helm-ls-git-deleted-and-staged-face ((,class (:foreground ""))))
+ ;; `(helm-ls-git-deleted-not-staged-face ((,class (:foreground ""))))
+ ;; `(helm-ls-git-modified-and-staged-face ((,class (:foreground ""))))
+ `(helm-ls-git-modified-not-staged-face ((,class (:foreground "#BA36A5"))))
+ ;; `(helm-ls-git-renamed-modified-face ((,class (:foreground ""))))
+ ;; `(helm-ls-git-untracked-face ((,class (:foreground ""))))
`(helm-match ((,class ,match)))
`(helm-moccur-buffer ((,class (:foreground "#0066CC"))))
- `(helm-selection ((,class ,volatile-highlight)))
- `(helm-selection-line ((,class ,volatile-highlight)))
- `(helm-source-header ((,class (:family "Sans Serif" :height 1.3 :weight
bold :foreground "white" :background "#2F69BF"))))
- `(helm-swoop-target-line-face ((,class ,volatile-highlight)))
+ `(helm-selection ((,class (:background "#3875D6" :foreground "white"))))
+ `(helm-selection-line ((,class ,highlight-gray))) ; ???
+ `(helm-separator ((,class (:foreground "red"))))
+ `(helm-source-header ((,class (:weight bold :box (:line-width 1 :color
"#C7C7C7") :background "#DEDEDE" :foreground "black"))))
`(helm-swoop-target-line-block-face ((,class (:background "#CCCC00"
:foreground "#222222"))))
+ `(helm-swoop-target-line-face ((,class (:background "#CCCCFF"))))
`(helm-swoop-target-word-face ((,class (:weight bold :foreground nil
:background "#FDBD33"))))
`(helm-visible-mark ((,class ,marked-line)))
`(helm-w3m-bookmarks-face ((,class (:underline t :foreground "cyan1"))))
+ `(highlight-changes ((,class (:foreground nil)))) ;; blue "#2E08B5"
+ `(highlight-changes-delete ((,class (:strike-through nil :foreground
nil)))) ;; red "#B5082E"
`(highlight-symbol-face ((,class (:background "#FFFFA0"))))
- `(hl-line ((,class ,highlight-line)))
- `(hl-tags-face ((,class (:background "#FEFCAE"))))
+ `(hl-line ((,class ,highlight-yellow))) ; Highlight current line.
+ `(hl-tags-face ((,class ,highlight-current-tag))) ; ~ Pair highlighting
(matching tags).
`(holiday-face ((,class (:foreground "#777777" :background "#E4EBFE"))))
`(html-helper-bold-face ((,class (:weight bold :foreground "black"))))
`(html-helper-italic-face ((,class (:slant italic :foreground "black"))))
@@ -448,9 +613,11 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(ilog-echo-face ((,class (:height 2.0 :foreground "#006FE0"))))
`(ilog-load-face ((,class (:foreground "#BA36A5"))))
`(ilog-message-face ((,class (:foreground "#808080"))))
+ `(indent-guide-face ((,class (:foreground "#D3D3D3"))))
`(info-file ((,class (:family "Sans Serif" :height 1.8 :weight bold :box
(:line-width 1 :color "#0000CC") :foreground "cornflower blue" :background
"LightSteelBlue1"))))
`(info-header-node ((,class (:underline t :foreground "orange")))) ; nodes
in header
`(info-header-xref ((,class (:underline t :foreground "dodger blue")))) ;
cross references in header
+ `(info-index-match ((,class (:weight bold :foreground nil :background
"#FDBD33")))) ; when using `i'
`(info-menu-header ((,class ,ol2))) ; menu titles (headers) -- major topics
`(info-menu-star ((,class (:foreground "black")))) ; every 3rd menu item
`(info-node ((,class (:underline t :foreground "blue")))) ; node names
@@ -459,16 +626,49 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(info-title-1 ((,class ,ol1)))
`(info-xref ((,class (:underline t :foreground "#006DAF")))) ; unvisited
cross-references
`(info-xref-visited ((,class (:underline t :foreground "magenta4")))) ;
previously visited cross-references
+ ;; js2-highlight-vars-face (~ auto-highlight-symbol)
+ `(js2-error ((,class (:box (:line-width 1 :color "#FF3737") :background
"#FFC8C8")))) ; DONE.
+ `(js2-external-variable ((,class (:foreground "#FF0000" :background
"#FFF8F8")))) ; DONE.
+ `(js2-function-param ((,class ,function-param)))
+ `(js2-instance-member ((,class (:foreground "DarkOrchid"))))
+ `(js2-jsdoc-html-tag-delimiter ((,class (:foreground "#D0372D"))))
+ `(js2-jsdoc-html-tag-name ((,class (:foreground "#D0372D"))))
+ `(js2-jsdoc-tag ((,class (:weight normal :foreground "#6434A3"))))
+ `(js2-jsdoc-type ((,class (:foreground "SteelBlue"))))
+ `(js2-jsdoc-value ((,class (:weight normal :foreground "#BA36A5")))) ;
#800080
+ `(js2-magic-paren ((,class (:underline t))))
+ `(js2-private-function-call ((,class (:foreground "goldenrod"))))
+ `(js2-private-member ((,class (:foreground "PeachPuff3"))))
+ `(js2-warning ((,class (:underline "orange"))))
+
+ ;; Org non-standard faces.
+ `(leuven-org-deadline-overdue ((,class (:foreground "#F22659"))))
+ `(leuven-org-deadline-today ((,class (:weight bold :foreground "#4F4A3D"
:background "#FFFFCC"))))
+ `(leuven-org-deadline-tomorrow ((,class (:foreground "#40A80B"))))
+ `(leuven-org-deadline-future ((,class (:foreground "#40A80B"))))
+ `(leuven-gnus-unseen ((,class (:weight bold :foreground "#FC7202"))))
+ `(leuven-gnus-date ((,class (:foreground "#FF80BF"))))
+ `(leuven-gnus-size ((,class (:foreground "#8FBF60"))))
+ `(leuven-todo-items-face ((,class (:weight bold :foreground "#FF3125"
:background "#FFFF88"))))
+
`(light-symbol-face ((,class (:background "#FFFFA0"))))
- `(linum ((,class (:inherit (default shadow) :foreground "#9A9A9A"
:background "#EDEDED"))))
+ `(linum ((,class (:foreground "#9A9A9A" :background "#EDEDED"))))
`(log-view-file ((,class (:foreground "#0000CC" :background "#EAF2F5"))))
+ `(log-view-message ((,class (:foreground "black" :background "#EDEA74"))))
+ `(lsp-ui-doc-background ((,class (:background "#F6FECD"))))
`(lui-button-face ((,class ,link)))
`(lui-highlight-face ((,class (:box '(:line-width 1 :color "#CC0000")
:foreground "#CC0000" :background "#FFFF88")))) ; my nickname
`(lui-time-stamp-face ((,class (:foreground "purple"))))
+ `(magit-blame-header ((,class (:inherit magit-diff-file-header))))
+ `(magit-blame-heading ((,class (:overline "#A7A7A7" :foreground "red"
:background "#E6E6E6"))))
+ `(magit-blame-hash ((,class (:overline "#A7A7A7" :foreground "red"
:background "#E6E6E6"))))
+ `(magit-blame-name ((,class (:overline "#A7A7A7" :foreground "#036A07"
:background "#E6E6E6"))))
+ `(magit-blame-date ((,class (:overline "#A7A7A7" :foreground "blue"
:background "#E6E6E6"))))
+ `(magit-blame-summary ((,class (:overline "#A7A7A7" :weight bold
:foreground "#707070" :background "#E6E6E6"))))
`(magit-branch ((,class ,vc-branch)))
`(magit-diff-add ((,class ,diff-added)))
`(magit-diff-del ((,class ,diff-removed)))
- `(magit-diff-file-header ((,class (:family "Sans Serif" :height 1.1 :weight
bold :foreground "#4183C4"))))
+ `(magit-diff-file-header ((,class (:height 1.1 :weight bold :foreground
"#4183C4"))))
`(magit-diff-hunk-header ((,class ,diff-hunk-header)))
`(magit-diff-none ((,class ,diff-none)))
`(magit-header ((,class (:foreground "white" :background "#FF4040"))))
@@ -476,48 +676,82 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(magit-item-mark ((,class ,marked-line)))
`(magit-log-head-label ((,class (:box (:line-width 1 :color "blue" :style
nil)))))
`(magit-log-tag-label ((,class (:box (:line-width 1 :color "#00CC00" :style
nil)))))
+ `(magit-section-highlight ((,class (:background "#F6FECD"))))
`(magit-section-title ((,class (:family "Sans Serif" :height 1.8 :weight
bold :foreground "cornflower blue" :inherit nil))))
`(makefile-space-face ((,class (:background "hot pink"))))
`(makefile-targets ((,class (:weight bold :foreground "blue"))))
- `(match ((,class ,match)))
+ ;; `(markdown-blockquote-face ((,class ())))
+ `(markdown-bold-face ((,class (:inherit bold))))
+ ;; `(markdown-comment-face ((,class ())))
+ ;; `(markdown-footnote-face ((,class ())))
+ ;; `(markdown-header-delimiter-face ((,class ())))
+ ;; `(markdown-header-face ((,class ())))
+ `(markdown-header-face-1 ((,class ,ol1)))
+ `(markdown-header-face-2 ((,class ,ol2)))
+ `(markdown-header-face-3 ((,class ,ol3)))
+ `(markdown-header-face-4 ((,class ,ol4)))
+ `(markdown-header-face-5 ((,class ,ol5)))
+ `(markdown-header-face-6 ((,class ,ol6)))
+ ;; `(markdown-header-rule-face ((,class ())))
+ `(markdown-inline-code-face ((,class ,code-inline)))
+ `(markdown-italic-face ((,class (:inherit italic))))
+ `(markdown-language-keyword-face ((,class (:inherit org-block-begin-line))))
+ ;; `(markdown-line-break-face ((,class ())))
+ `(markdown-link-face ((,class ,link-no-underline)))
+ ;; `(markdown-link-title-face ((,class ())))
+ ;; `(markdown-list-face ((,class ())))
+ ;; `(markdown-math-face ((,class ())))
+ ;; `(markdown-metadata-key-face ((,class ())))
+ ;; `(markdown-metadata-value-face ((,class ())))
+ ;; `(markdown-missing-link-face ((,class ())))
+ `(markdown-pre-face ((,class (:inherit org-block-background))))
+ ;; `(markdown-reference-face ((,class ())))
+ ;; `(markdown-strike-through-face ((,class ())))
+ `(markdown-url-face ((,class ,link)))
+ `(match ((,class ,match))) ; Used for grep matches.
+ `(mc/cursor-bar-face ((,class (:height 1.0 :foreground "#1664C4"
:background "#1664C4"))))
+ `(mc/cursor-face ((,class (:inverse-video t))))
+ `(mc/region-face ((,class (:inherit region))))
`(mm-uu-extract ((,class ,code-block)))
`(moccur-current-line-face ((,class (:foreground "black" :background
"#FFFFCC"))))
`(moccur-face ((,class (:foreground "black" :background "#FFFF99"))))
- `(next-error ((,class ,volatile-highlight)))
+ `(next-error ((,class ,volatile-highlight-supersize)))
`(nobreak-space ((,class (:background "#CCE8F6"))))
- `(nxml-attribute-local-name-face ((,class (:foreground "magenta"))))
+ `(nxml-attribute-local-name-face ((,class ,xml-attribute)))
`(nxml-attribute-value-delimiter-face ((,class (:foreground "green4"))))
`(nxml-attribute-value-face ((,class (:foreground "green4"))))
`(nxml-comment-content-face ((,class (:slant italic :foreground "red"))))
`(nxml-comment-delimiter-face ((,class (:foreground "red"))))
- `(nxml-element-local-name ((,class (:box (:line-width 1 :color "#999999")
:foreground "#000088" :background "#DEDEDE"))))
+ `(nxml-element-local-name ((,class ,xml-tag)))
`(nxml-element-local-name-face ((,class (:foreground "blue"))))
`(nxml-processing-instruction-target-face ((,class (:foreground
"purple1"))))
`(nxml-tag-delimiter-face ((,class (:foreground "blue"))))
`(nxml-tag-slash-face ((,class (:foreground "blue"))))
`(org-agenda-block-count ((,class (:weight bold :foreground "#A5A5A5"))))
- `(org-agenda-calendar-event ((,class (:weight bold :foreground "#3774CC"
:background "#A8C5EF"))))
- `(org-agenda-calendar-sexp ((,class (:foreground "#777777" :background
"#E4EBFE"))))
+ `(org-agenda-calendar-event ((,class (:weight bold :foreground "#3774CC"
:background "#E4EBFE"))))
+ `(org-agenda-calendar-sexp ((,class (:foreground "#327ACD" :background
"#F3F7FC"))))
`(org-agenda-clocking ((,class (:foreground "black" :background
"#EEC900"))))
`(org-agenda-column-dateline ((,class ,column)))
`(org-agenda-current-time ((,class (:underline t :foreground "#1662AF"))))
- `(org-agenda-date ((,class (:height 1.6 :weight bold :foreground
"#1662AF"))))
- `(org-agenda-date-today ((,class (:height 1.6 :weight bold :foreground
"#4F4A3D" :background "#FFFFCC"))))
- `(org-agenda-date-weekend ((,class (:height 1.6 :weight bold :foreground
"#4E4E4E"))))
+ `(org-agenda-date ((,class (,@(leuven-scale-font
leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#1662AF"))))
+ `(org-agenda-date-today ((,class (,@(leuven-scale-font
leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#4F4A3D"
:background "#FFFFCC"))))
+ `(org-agenda-date-weekend ((,class (,@(leuven-scale-font
leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#4E4E4E"))))
`(org-agenda-diary ((,class (:weight bold :foreground "green4" :background
"light blue"))))
`(org-agenda-dimmed-todo-face ((,class (:foreground "gold2"))))
`(org-agenda-done ((,class (:foreground "#555555"))))
`(org-agenda-filter-category ((,class (:weight bold :foreground "orange"))))
+ `(org-agenda-filter-effort ((,class (:weight bold :foreground "orange"))))
+ `(org-agenda-filter-regexp ((,class (:weight bold :foreground "orange"))))
`(org-agenda-filter-tags ((,class (:weight bold :foreground "orange"))))
`(org-agenda-restriction-lock ((,class (:background "#E77D63"))))
- `(org-agenda-structure ((,class (:height 1.6 :weight bold :foreground
"#1F8DD6"))))
+ `(org-agenda-structure ((,class (,@(leuven-scale-font
leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#1F8DD6"))))
`(org-archived ((,class (:foreground "gray70"))))
`(org-beamer-tag ((,class (:box (:line-width 1 :color "#FABC18")
:foreground "#2C2C2C" :background "#FFF8D0"))))
`(org-block ((,class ,code-block)))
- `(org-block-background ((,class (:background "#FFFFE0"))))
+ `(org-block-background ((,class (:background "#FFFFE0")))) ;; :inherit
fixed-pitch))))
`(org-block-begin-line ((,class (:underline "#A7A6AA" :foreground "#555555"
:background "#E2E1D5"))))
`(org-block-end-line ((,class (:overline "#A7A6AA" :foreground "#555555"
:background "#E2E1D5"))))
- `(org-checkbox ((,class (:weight bold :box (:line-width 1 :style
pressed-button) :foreground "white" :background "#777777"))))
+ `(org-checkbox ((,class (:weight bold :box (:line-width 1 :style
pressed-button) :foreground "#123555" :background "#A3A3A3"))))
`(org-clock-overlay ((,class (:foreground "white" :background "SkyBlue4"))))
`(org-code ((,class ,code-inline)))
`(org-column ((,class ,column)))
@@ -527,14 +761,14 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(org-dim ((,class (:foreground "#AAAAAA"))))
`(org-document-info ((,class (:foreground "#484848"))))
`(org-document-info-keyword ((,class (:foreground "#008ED1" :background
"#EAEAFF"))))
- `(org-document-title ((,class (:family "Sans Serif" :height 1.8 :weight
bold :foreground "black"))))
+ `(org-document-title ((,class (:height 1.8 :weight bold :foreground
"black"))))
`(org-done ((,class (:weight bold :box (:line-width 1 :color "#BBBBBB")
:foreground "#BBBBBB" :background "#F0F0F0"))))
- `(org-drawer ((,class (:foreground "light sky blue"))))
- `(org-ellipsis ((,class (:underline nil :box (:line-width 1 :color
"#999999") :foreground "#999999" :background "#FFF8C0")))) ; #FFEE62
+ `(org-drawer ((,class (:weight bold :foreground "#00BB00" :background
"#EAFFEA" :extend nil))))
+ `(org-ellipsis ((,class (:underline nil :foreground "#999999")))) ; #FFEE62
`(org-example ((,class (:foreground "blue" :background "#EAFFEA"))))
`(org-footnote ((,class (:underline t :foreground "#008ED1"))))
`(org-formula ((,class (:foreground "chocolate1"))))
- `(org-headline-done ((,class (:height 1.0 :weight normal :strike-through t
:foreground "#ADADAD"))))
+ `(org-headline-done ((,class (:height 1.0 :weight normal :foreground
"#ADADAD"))))
`(org-hide ((,class (:foreground "#E2E2E2"))))
`(org-inlinetask ((,class (:box (:line-width 1 :color "#EBEBEB")
:foreground "#777777" :background "#FFFFD6"))))
`(org-latex-and-related ((,class (:foreground "#336699" :background
"white"))))
@@ -548,25 +782,25 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(org-level-8 ((,class ,ol8)))
`(org-link ((,class ,link)))
`(org-list-dt ((,class (:weight bold :foreground "#335EA8"))))
- `(org-macro ((,class (:foreground "white" :background "#EDB802"))))
+ `(org-macro ((,class (:weight bold :foreground "#EDB802"))))
`(org-meta-line ((,class (:slant normal :foreground "#008ED1" :background
"#EAEAFF"))))
- `(org-mode-line-clock ((,class ,clock-line)))
+ `(org-mode-line-clock ((,class (:box (:line-width 1 :color "#335EA8")
:foreground "black" :background "#FFA335"))))
`(org-mode-line-clock-overrun ((,class (:weight bold :box (:line-width 1
:color "#335EA8") :foreground "white" :background "#FF4040"))))
`(org-number-of-items ((,class (:weight bold :foreground "white"
:background "#79BA79"))))
`(org-property-value ((,class (:foreground "#00A000"))))
`(org-quote ((,class (:slant italic :foreground "dim gray" :background
"#FFFFE0"))))
`(org-scheduled ((,class (:foreground "#333333"))))
- `(org-scheduled-previously ((,class (:foreground "#F22659"))))
+ `(org-scheduled-previously ((,class (:foreground "#1466C6"))))
`(org-scheduled-today ((,class (:weight bold :foreground "#4F4A3D"
:background "#FFFFCC"))))
`(org-sexp-date ((,class (:foreground "#3774CC"))))
`(org-special-keyword ((,class (:weight bold :foreground "#00BB00"
:background "#EAFFEA"))))
- `(org-table ((,class (:foreground "dark green" :background "#EAFFEA"))))
+ `(org-table ((,class (:foreground "dark green" :background "#EAFFEA")))) ;;
:inherit fixed-pitch))))
`(org-tag ((,class (:weight normal :slant italic :foreground "#9A9FA4"
:background "white"))))
- `(org-target ((,class ,link)))
+ `(org-target ((,class (:foreground "#FF6DAF"))))
`(org-time-grid ((,class (:foreground "#CFCFCF"))))
`(org-todo ((,class (:weight bold :box (:line-width 1 :color "#D8ABA7")
:foreground "#D8ABA7" :background "#FFE6E4"))))
`(org-upcoming-deadline ((,class (:foreground "#FF5555"))))
- `(org-verbatim ((,class (:foreground "#0066CC"))))
+ `(org-verbatim ((,class (:foreground "#0066CC" :background "#F7FDFF"))))
`(org-verse ((,class (:slant italic :foreground "dim gray" :background
"#EEEEEE"))))
`(org-warning ((,class (:weight bold :foreground "black" :background
"#CCE7FF"))))
`(outline-1 ((,class ,ol1)))
@@ -577,17 +811,17 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(outline-6 ((,class ,ol6)))
`(outline-7 ((,class ,ol7)))
`(outline-8 ((,class ,ol8)))
- `(pabbrev-debug-display-label-face ((,class (:background "chartreuse"))))
+ `(pabbrev-debug-display-label-face ((,class (:foreground "white"
:background "#A62154"))))
`(pabbrev-suggestions-face ((,class (:weight bold :foreground "white"
:background "red"))))
`(pabbrev-suggestions-label-face ((,class (:weight bold :foreground "white"
:background "purple"))))
`(paren-face-match ((,class ,paren-matched)))
`(paren-face-mismatch ((,class ,paren-unmatched)))
`(paren-face-no-match ((,class ,paren-unmatched)))
`(persp-selected-face ((,class (:weight bold :foreground "#EEF5FE"))))
- `(powerline-active1 ((,class (:background "grey22" :inherit mode-line))))
- `(powerline-active2 ((,class (:background "#4070B6" :inherit mode-line))))
- `(powerline-inactive1 ((,class (:background "#686868" :inherit
mode-line-inactive))))
- `(powerline-inactive2 ((,class (:background "#A9A9A9" :inherit
mode-line-inactive))))
+ `(powerline-active1 ((,class (:foreground "#85CEEB" :background "#383838"
:inherit mode-line))))
+ `(powerline-active2 ((,class (:foreground "#85CEEB" :background "#4070B6"
:inherit mode-line))))
+ `(powerline-inactive1 ((,class (:foreground "#F0F0EF" :background "#686868"
:inherit mode-line-inactive))))
+ `(powerline-inactive2 ((,class (:foreground "#F0F0EF" :background "#A9A9A9"
:inherit mode-line-inactive))))
`(rainbow-delimiters-depth-1-face ((,class (:foreground "#707183"))))
`(rainbow-delimiters-depth-2-face ((,class (:foreground "#7388D6"))))
`(rainbow-delimiters-depth-3-face ((,class (:foreground "#909183"))))
@@ -599,29 +833,33 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(rainbow-delimiters-depth-9-face ((,class (:foreground "#887070"))))
`(rainbow-delimiters-mismatched-face ((,class ,paren-unmatched)))
`(rainbow-delimiters-unmatched-face ((,class ,paren-unmatched)))
- `(realgud-overlay-arrow1 ((,class (:foreground "#005522"))))
- `(realgud-overlay-arrow2 ((,class (:foreground "#c18401"))))
- `(realgud-overlay-arrow3 ((,class (:foreground "#909183"))))
- `(realgud-bp-disabled-face ((,class (:foreground "#909183"))))
- `(realgud-bp-line-enabled-face ((,class (:underline "red"))))
- `(realgud-bp-line-disabled-face ((,class (:underline "#909183"))))
- `(realgud-file-name ((,class :foreground "#005522")))
- `(realgud-line-number ((,class :foreground "#A535AE")))
- `(realgud-backtrace-number ((,class :foreground "#A535AE" :weight
bold)))
`(recover-this-file ((,class (:weight bold :background "#FF3F3F"))))
`(rng-error ((,class (:weight bold :foreground "red" :background
"#FBE3E4"))))
`(sh-heredoc ((,class (:foreground "blue" :background "#EEF5FE"))))
`(sh-quoted-exec ((,class (:foreground "#FF1493"))))
- `(shadow ((,class ,shadow)))
+ `(shadow ((,class ,shadow))) ; Used for grep context lines.
`(shell-option-face ((,class (:foreground "forest green"))))
`(shell-output-2-face ((,class (:foreground "blue"))))
`(shell-output-3-face ((,class (:foreground "purple"))))
`(shell-output-face ((,class (:foreground "black"))))
;; `(shell-prompt-face ((,class (:weight bold :foreground "yellow"))))
+ `(shm-current-face ((,class (:background "#EEE8D5"))))
+ `(shm-quarantine-face ((,class (:background "lemonchiffon"))))
`(show-paren-match ((,class ,paren-matched)))
`(show-paren-mismatch ((,class ,paren-unmatched)))
`(sml-modeline-end-face ((,class (:background "#6BADF6")))) ; #335EA8
`(sml-modeline-vis-face ((,class (:background "#1979CA"))))
+ `(term ((,class (:foreground "#333333" :background "#FFFFFF"))))
+
+ ;; `(sp-pair-overlay-face ((,class ())))
+ ;; `(sp-show-pair-enclosing ((,class ())))
+ ;; `(sp-show-pair-match-face ((,class ()))) ; ~ Pair highlighting (matching
tags).
+ ;; `(sp-show-pair-mismatch-face ((,class ())))
+ ;; `(sp-wrap-overlay-closing-pair ((,class ())))
+ ;; `(sp-wrap-overlay-face ((,class ())))
+ ;; `(sp-wrap-overlay-opening-pair ((,class ())))
+ ;; `(sp-wrap-tag-overlay-face ((,class ())))
+
`(speedbar-button-face ((,class (:foreground "green4"))))
`(speedbar-directory-face ((,class (:foreground "blue4"))))
`(speedbar-file-face ((,class (:foreground "cyan4"))))
@@ -639,7 +877,6 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(tex-verbatim ((,class (:foreground "blue"))))
`(tool-bar ((,class (:box (:line-width 1 :style released-button)
:foreground "black" :background "gray75"))))
`(tooltip ((,class (:foreground "black" :background "light yellow"))))
- `(trailing-whitespace ((,class (:background "#F6EBFE"))))
`(traverse-match-face ((,class (:weight bold :foreground "blue violet"))))
`(vc-annotate-face-3F3FFF ((,class (:foreground "#3F3FFF" :background
"black"))))
`(vc-annotate-face-3F6CFF ((,class (:foreground "#3F3FFF" :background
"black"))))
@@ -654,11 +891,24 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(vc-annotate-face-83FF3F ((,class (:foreground "#B0FF3F" :background
"black"))))
`(vc-annotate-face-B0FF3F ((,class (:foreground "#B0FF3F" :background
"black"))))
`(vc-annotate-face-DDFF3F ((,class (:foreground "#FFF33F" :background
"black"))))
+ `(vc-annotate-face-F6FFCC ((,class (:foreground "black" :background
"#FFFFC0"))))
`(vc-annotate-face-FF3F3F ((,class (:foreground "#FF3F3F" :background
"black"))))
`(vc-annotate-face-FF6C3F ((,class (:foreground "#FF3F3F" :background
"black"))))
`(vc-annotate-face-FF993F ((,class (:foreground "#FF993F" :background
"black"))))
`(vc-annotate-face-FFC63F ((,class (:foreground "#FF993F" :background
"black"))))
`(vc-annotate-face-FFF33F ((,class (:foreground "#FFF33F" :background
"black"))))
+
+ ;; ;; vc
+ ;; (vc-up-to-date-state ((,c :foreground ,(gc 'green-1))))
+ ;; (vc-edited-state ((,c :foreground ,(gc 'yellow+1))))
+ ;; (vc-missing-state ((,c :foreground ,(gc 'red))))
+ ;; (vc-conflict-state ((,c :foreground ,(gc 'red+2) :weight bold)))
+ ;; (vc-locked-state ((,c :foreground ,(gc 'cyan-1))))
+ ;; (vc-locally-added-state ((,c :foreground ,(gc 'blue))))
+ ;; (vc-needs-update-state ((,c :foreground ,(gc 'magenta))))
+ ;; (vc-removed-state ((,c :foreground ,(gc 'red-1))))
+
+ `(vhl/default-face ((,class ,volatile-highlight))) ;
`volatile-highlights.el' (for undo, yank).
`(w3m-anchor ((,class ,link)))
`(w3m-arrived-anchor ((,class (:foreground "purple1"))))
`(w3m-bitmap-image-face ((,class (:foreground "gray4" :background
"green"))))
@@ -675,38 +925,138 @@ Semantic, and Ansi-Color faces are included -- and much
more...")
`(w3m-link-numbering ((,class (:foreground "#B4C7EB")))) ; mouseless
browsing
`(w3m-strike-through-face ((,class (:strike-through t))))
`(w3m-underline-face ((,class (:underline t))))
- `(which-func ((,class (:weight bold :foreground "white"))))
+
+ ;; `(web-mode-block-attr-name-face ((,class ())))
+ ;; `(web-mode-block-attr-value-face ((,class ())))
+ ;; `(web-mode-block-comment-face ((,class ())))
+ ;; `(web-mode-block-control-face ((,class ())))
+ ;; `(web-mode-block-delimiter-face ((,class ())))
+ ;; `(web-mode-block-face ((,class ())))
+ ;; `(web-mode-block-string-face ((,class ())))
+ ;; `(web-mode-bold-face ((,class ())))
+ ;; `(web-mode-builtin-face ((,class ())))
+ ;; `(web-mode-comment-face ((,class ())))
+ ;; `(web-mode-comment-keyword-face ((,class ())))
+ ;; `(web-mode-constant-face ((,class ())))
+ ;; `(web-mode-css-at-rule-face ((,class ())))
+ ;; `(web-mode-css-color-face ((,class ())))
+ ;; `(web-mode-css-comment-face ((,class ())))
+ ;; `(web-mode-css-function-face ((,class ())))
+ ;; `(web-mode-css-priority-face ((,class ())))
+ ;; `(web-mode-css-property-name-face ((,class ())))
+ ;; `(web-mode-css-pseudo-class-face ((,class ())))
+ ;; `(web-mode-css-selector-face ((,class ())))
+ ;; `(web-mode-css-string-face ((,class ())))
+ ;; `(web-mode-css-variable-face ((,class ())))
+ ;; `(web-mode-current-column-highlight-face ((,class ())))
+ `(web-mode-current-element-highlight-face ((,class (:background
"#99CCFF")))) ; #FFEE80
+ ;; `(web-mode-doctype-face ((,class ())))
+ ;; `(web-mode-error-face ((,class ())))
+ ;; `(web-mode-filter-face ((,class ())))
+ `(web-mode-folded-face ((,class (:box (:line-width 1 :color "#777777")
:foreground "#9A9A6A" :background "#F3F349"))))
+ ;; `(web-mode-function-call-face ((,class ())))
+ ;; `(web-mode-function-name-face ((,class ())))
+ ;; `(web-mode-html-attr-custom-face ((,class ())))
+ ;; `(web-mode-html-attr-engine-face ((,class ())))
+ ;; `(web-mode-html-attr-equal-face ((,class ())))
+ `(web-mode-html-attr-name-face ((,class ,xml-attribute)))
+ ;; `(web-mode-html-attr-value-face ((,class ())))
+ ;; `(web-mode-html-entity-face ((,class ())))
+ `(web-mode-html-tag-bracket-face ((,class ,xml-tag)))
+ ;; `(web-mode-html-tag-custom-face ((,class ())))
+ `(web-mode-html-tag-face ((,class ,xml-tag)))
+ ;; `(web-mode-html-tag-namespaced-face ((,class ())))
+ ;; `(web-mode-inlay-face ((,class ())))
+ ;; `(web-mode-italic-face ((,class ())))
+ ;; `(web-mode-javascript-comment-face ((,class ())))
+ ;; `(web-mode-javascript-string-face ((,class ())))
+ ;; `(web-mode-json-comment-face ((,class ())))
+ ;; `(web-mode-json-context-face ((,class ())))
+ ;; `(web-mode-json-key-face ((,class ())))
+ ;; `(web-mode-json-string-face ((,class ())))
+ ;; `(web-mode-jsx-depth-1-face ((,class ())))
+ ;; `(web-mode-jsx-depth-2-face ((,class ())))
+ ;; `(web-mode-jsx-depth-3-face ((,class ())))
+ ;; `(web-mode-jsx-depth-4-face ((,class ())))
+ ;; `(web-mode-keyword-face ((,class ())))
+ ;; `(web-mode-param-name-face ((,class ())))
+ ;; `(web-mode-part-comment-face ((,class ())))
+ `(web-mode-part-face ((,class (:background "#FFFFE0"))))
+ ;; `(web-mode-part-string-face ((,class ())))
+ ;; `(web-mode-preprocessor-face ((,class ())))
+ `(web-mode-script-face ((,class (:background "#EFF0F1"))))
+ ;; `(web-mode-sql-keyword-face ((,class ())))
+ ;; `(web-mode-string-face ((,class ())))
+ ;; `(web-mode-style-face ((,class ())))
+ ;; `(web-mode-symbol-face ((,class ())))
+ ;; `(web-mode-type-face ((,class ())))
+ ;; `(web-mode-underline-face ((,class ())))
+ ;; `(web-mode-variable-name-face ((,class ())))
+ ;; `(web-mode-warning-face ((,class ())))
+ ;; `(web-mode-whitespace-face ((,class ())))
+
+ `(which-func ((,class (:weight bold :slant italic :foreground "white"))))
+ ;; `(which-key-command-description-face)
+ ;; `(which-key-group-description-face)
+ ;; `(which-key-highlighted-command-face)
+ ;; `(which-key-key-face)
+ `(which-key-local-map-description-face ((,class (:weight bold :background
"#F3F7FC" :inherit which-key-command-description-face))))
+ ;; `(which-key-note-face)
+ ;; `(which-key-separator-face)
+ ;; `(which-key-special-key-face)
`(widget-button ((,class ,link)))
`(widget-button-pressed ((,class (:foreground "red"))))
`(widget-documentation ((,class (:foreground "green4"))))
`(widget-field ((,class (:background "gray85"))))
`(widget-inactive ((,class (:foreground "dim gray"))))
`(widget-single-line-field ((,class (:background "gray85"))))
- `(yas/field-debug-face ((,class (:background "ivory2"))))
- `(yas/field-highlight-face ((,class (:background "DarkSeaGreen1"))))
+ `(woman-bold ((,class (:weight bold :foreground "#F13D3D"))))
+ `(woman-italic ((,class (:weight bold :slant italic :foreground
"#46BE1B"))))
+ `(woman-symbol ((,class (:weight bold :foreground "purple"))))
+ `(yas-field-debug-face ((,class (:foreground "white" :background
"#A62154"))))
+ `(yas-field-highlight-face ((,class (:box (:line-width 1 :color "#838383")
:foreground "black" :background "#D4DCD8"))))
+
+ ;; `(ztreep-arrow-face ((,class ())))
+ ;; `(ztreep-diff-header-face ((,class ())))
+ ;; `(ztreep-diff-header-small-face ((,class ())))
+ `(ztreep-diff-model-add-face ((,class (:weight bold :foreground
"#008800"))))
+ `(ztreep-diff-model-diff-face ((,class (:weight bold :foreground
"#0044DD"))))
+ `(ztreep-diff-model-ignored-face ((,class (:strike-through t :foreground
"#9E9E9E"))))
+ `(ztreep-diff-model-normal-face ((,class (:foreground "#000000"))))
+ ;; `(ztreep-expand-sign-face ((,class ())))
+ ;; `(ztreep-header-face ((,class ())))
+ ;; `(ztreep-leaf-face ((,class ())))
+ ;; `(ztreep-node-face ((,class ())))
+
))
(custom-theme-set-variables 'leuven
- '(ansi-color-faces-vector
- [default default default italic underline success warning error])
- '(ansi-color-names-vector
- ["black" "red3" "ForestGreen" "yellow3" "blue" "magenta3" "DeepSkyBlue"
"gray50"])
- ; colors used in Shell mode
+
+ ;; highlight-sexp-mode.
+ '(hl-sexp-background-color "#efebe9")
+
+ '(ansi-color-faces-vector
+ [default default default italic underline success warning error])
+
+ ;; Colors used in Shell mode.
+ '(ansi-color-names-vector
+ ["black" "red3" "ForestGreen" "yellow3" "blue" "magenta3" "DeepSkyBlue"
"gray50"])
)
;;;###autoload
(when (and (boundp 'custom-theme-load-path)
load-file-name)
- ;; add theme folder to `custom-theme-load-path' when installing over MELPA
+ ;; Add theme folder to `custom-theme-load-path' when installing over MELPA.
(add-to-list 'custom-theme-load-path
(file-name-as-directory (file-name-directory load-file-name))))
(provide-theme 'leuven)
+;; This is for the sake of Emacs.
;; Local Variables:
+;; time-stamp-end: "$"
;; time-stamp-format: "%:y%02m%02d.%02H%02M"
;; time-stamp-start: "Version: "
-;; time-stamp-end: "$"
;; End:
;;; leuven-theme.el ends here
diff --git a/etc/tutorials/TUTORIAL b/etc/tutorials/TUTORIAL
index eb3acde..227c13f 100644
--- a/etc/tutorials/TUTORIAL
+++ b/etc/tutorials/TUTORIAL
@@ -612,11 +612,11 @@ but it also means that you need a convenient way to save
the first
file's buffer. Having to switch back to that buffer, in order to save
it with C-x C-s, would be a nuisance. So we have
- C-x s Save some buffers
+ C-x s Save some buffers to their files
-C-x s asks you about each buffer which contains changes that you have
-not saved. It asks you, for each such buffer, whether to save the
-buffer.
+C-x s asks you about each file-visiting buffer which contains changes
+that you have not saved. It asks you, for each such buffer, whether
+to save the buffer to its file.
>> Insert a line of text, then type C-x s.
It should ask you whether to save the buffer named TUTORIAL.
@@ -660,8 +660,8 @@ as by a mail handling utility.
There are many C-x commands. Here is a list of the ones you have learned:
C-x C-f Find file
- C-x C-s Save file
- C-x s Save some buffers
+ C-x C-s Save buffer to file
+ C-x s Save some buffers to their files
C-x C-b List buffers
C-x b Switch buffer
C-x C-c Quit Emacs
@@ -1081,7 +1081,7 @@ corresponding command names (such as C-x C-f beside
find-file).
You can learn more about Emacs by reading its manual, either as a
printed book, or inside Emacs (use the Help menu or type C-h r).
Two features that you may like especially are completion, which saves
-typing, and dired, which simplifies file handling.
+typing, and Dired, which simplifies file handling.
Completion is a way to avoid unnecessary typing. For instance, if you
want to switch to the *Messages* buffer, you can type C-x b *M<Tab>
diff --git a/lib/c++defs.h b/lib/c++defs.h
index 3e6aaab..182c2b3 100644
--- a/lib/c++defs.h
+++ b/lib/c++defs.h
@@ -268,7 +268,7 @@
_GL_CXXALIASWARN_2 (func, namespace)
/* To work around GCC bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=43881>,
we enable the warning only when not optimizing. */
-# if !__OPTIMIZE__
+# if !(defined __GNUC__ && !defined __clang__ && __OPTIMIZE__)
# define _GL_CXXALIASWARN_2(func,namespace) \
_GL_WARN_ON_USE (func, \
"The symbol ::" #func " refers to the system function. " \
@@ -296,7 +296,7 @@
_GL_CXXALIASWARN1_2 (func, rettype, parameters_and_attributes, namespace)
/* To work around GCC bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=43881>,
we enable the warning only when not optimizing. */
-# if !__OPTIMIZE__
+# if !(defined __GNUC__ && !defined __clang__ && __OPTIMIZE__)
# define
_GL_CXXALIASWARN1_2(func,rettype,parameters_and_attributes,namespace) \
_GL_WARN_ON_USE_CXX (func, rettype, parameters_and_attributes, \
"The symbol ::" #func " refers to the system
function. " \
diff --git a/lib/cdefs.h b/lib/cdefs.h
index d8e4a00..f6c447a 100644
--- a/lib/cdefs.h
+++ b/lib/cdefs.h
@@ -401,7 +401,7 @@
# endif
#endif
-#if __GNUC__ >= 3
+#if (__GNUC__ >= 3) || (__clang_major__ >= 4)
# define __glibc_unlikely(cond) __builtin_expect ((cond), 0)
# define __glibc_likely(cond) __builtin_expect ((cond), 1)
#else
diff --git a/lib/count-leading-zeros.h b/lib/count-leading-zeros.h
index 7e88c8c..7cf605a 100644
--- a/lib/count-leading-zeros.h
+++ b/lib/count-leading-zeros.h
@@ -38,7 +38,8 @@ extern "C" {
expand to code that computes the number of leading zeros of the local
variable 'x' of type TYPE (an unsigned integer type) and return it
from the current function. */
-#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)
+#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) \
+ || (__clang_major__ >= 4)
# define COUNT_LEADING_ZEROS(BUILTIN, MSC_BUILTIN, TYPE) \
return x ? BUILTIN (x) : CHAR_BIT * sizeof x;
#elif _MSC_VER
diff --git a/lib/count-trailing-zeros.h b/lib/count-trailing-zeros.h
index 1eb5fb9..727b21d 100644
--- a/lib/count-trailing-zeros.h
+++ b/lib/count-trailing-zeros.h
@@ -38,7 +38,8 @@ extern "C" {
expand to code that computes the number of trailing zeros of the local
variable 'x' of type TYPE (an unsigned integer type) and return it
from the current function. */
-#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)
+#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) \
+ || (__clang_major__ >= 4)
# define COUNT_TRAILING_ZEROS(BUILTIN, MSC_BUILTIN, TYPE) \
return x ? BUILTIN (x) : CHAR_BIT * sizeof x;
#elif _MSC_VER
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index 4dc180d..92d0621 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -246,9 +246,10 @@ GL_GENERATE_ALLOCA_H = @GL_GENERATE_ALLOCA_H@
GL_GENERATE_BYTESWAP_H = @GL_GENERATE_BYTESWAP_H@
GL_GENERATE_ERRNO_H = @GL_GENERATE_ERRNO_H@
GL_GENERATE_EXECINFO_H = @GL_GENERATE_EXECINFO_H@
-GL_GENERATE_GMP_H = @GL_GENERATE_GMP_H@
+GL_GENERATE_GMP_GMP_H = @GL_GENERATE_GMP_GMP_H@
GL_GENERATE_IEEE754_H = @GL_GENERATE_IEEE754_H@
GL_GENERATE_LIMITS_H = @GL_GENERATE_LIMITS_H@
+GL_GENERATE_MINI_GMP_H = @GL_GENERATE_MINI_GMP_H@
GL_GENERATE_STDALIGN_H = @GL_GENERATE_STDALIGN_H@
GL_GENERATE_STDDEF_H = @GL_GENERATE_STDDEF_H@
GL_GENERATE_STDINT_H = @GL_GENERATE_STDINT_H@
@@ -1085,7 +1086,6 @@ gamedir = @gamedir@
gamegroup = @gamegroup@
gameuser = @gameuser@
gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 =
@gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@
-gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9 =
@gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9@
gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b =
@gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b@
gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 =
@gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31@
gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c =
@gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c@
@@ -2021,15 +2021,22 @@ ifeq (,$(OMIT_GNULIB_MODULE_libgmp))
BUILT_SOURCES += $(GMP_H)
+ifneq (,$(GL_GENERATE_MINI_GMP_H))
# Build gmp.h as a wrapper for mini-gmp.h when using mini-gmp.
-ifneq (,$(GL_GENERATE_GMP_H))
gmp.h: $(top_builddir)/config.status
echo '#include "mini-gmp.h"' >$@-t
mv $@-t $@
else
+ifneq (,$(GL_GENERATE_GMP_GMP_H))
+# Build gmp.h as a wrapper for gmp/gmp.h.
+gmp.h: $(top_builddir)/config.status
+ echo '#include <gmp/gmp.h>' >$@-t
+ mv $@-t $@
+else
gmp.h: $(top_builddir)/config.status
rm -f $@
endif
+endif
MOSTLYCLEANFILES += gmp.h gmp.h-t
EXTRA_DIST += mini-gmp-gnulib.c mini-gmp.c mini-gmp.h
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 035720b..9bccece 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -205,7 +205,6 @@ $(lisp)/finder-inf.el:
autoloads .PHONY: $(lisp)/loaddefs.el
$(lisp)/loaddefs.el: gen-lisp $(LOADDEFS)
- @echo Directories for loaddefs: ${SUBDIRS_ALMOST}
$(AM_V_GEN)$(emacs) -l autoload \
--eval '(setq autoload-ensure-writable t)' \
--eval '(setq autoload-builtin-package-versions t)' \
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 6781c29..ae85fc5 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -391,6 +391,7 @@ file. Archive and member name will be added."
(define-key map "e" 'archive-extract)
(define-key map "f" 'archive-extract)
(define-key map "\C-m" 'archive-extract)
+ (define-key map "C" 'archive-copy-file)
(define-key map "m" 'archive-mark)
(define-key map "n" 'archive-next-line)
(define-key map "\C-n" 'archive-next-line)
@@ -430,6 +431,9 @@ file. Archive and member name will be added."
(define-key map [menu-bar immediate view]
'(menu-item "View This File" archive-view
:help "Display file at cursor in View Mode"))
+ (define-key map [menu-bar immediate view]
+ '(menu-item "Copy This File" archive-copy-file
+ :help "Copy file at cursor to another location"))
(define-key map [menu-bar immediate display]
'(menu-item "Display in Other Window" archive-display-other-window
:help "Display file at cursor in another window"))
@@ -989,6 +993,75 @@ using `make-temp-file', and the generated name is
returned."
(kill-local-variable 'buffer-file-coding-system)
(after-insert-file-set-coding (- (point-max) (point-min))))))
+(defun archive-goto-file (file)
+ "Go to FILE in the current buffer.
+FILE should be a relative file name. If FILE can't be found,
+return nil. Otherwise point is returned."
+ (let ((start (point))
+ found)
+ (goto-char (point-min))
+ (while (and (not found)
+ (not (eobp)))
+ (forward-line 1)
+ (when-let ((descr (archive-get-descr t)))
+ (when (equal (archive--file-desc-ext-file-name descr) file)
+ (setq found t))))
+ (if (not found)
+ (progn
+ (goto-char start)
+ nil)
+ (point))))
+
+(defun archive-next-file-displayer (file regexp n)
+ "Return a closure to display the next file after FILE that matches REGEXP."
+ (let ((short (replace-regexp-in-string "\\`.*:" "" file))
+ next)
+ (archive-goto-file short)
+ (while (and (not next)
+ ;; Stop if we reach the end/start of the buffer.
+ (if (> n 0)
+ (not (eobp))
+ (not (save-excursion
+ (beginning-of-line)
+ (bobp)))))
+ (archive-next-line n)
+ (when-let ((descr (archive-get-descr t)))
+ (let ((candidate (archive--file-desc-ext-file-name descr))
+ (buffer (current-buffer)))
+ (when (and candidate
+ (string-match-p regexp candidate))
+ (setq next (lambda ()
+ (kill-buffer (current-buffer))
+ (switch-to-buffer buffer)
+ (archive-extract)))))))
+ (unless next
+ ;; If we didn't find a next/prev file, then restore
+ ;; point.
+ (archive-goto-file short))
+ next))
+
+(defun archive-copy-file (file new-name)
+ "Copy FILE to a location specified by NEW-NAME.
+Interactively, FILE is the file at point, and the function prompts
+for NEW-NAME."
+ (interactive
+ (let ((name (archive--file-desc-ext-file-name (archive-get-descr))))
+ (list name
+ (read-file-name (format "Copy %s to: " name)))))
+ (when (file-directory-p new-name)
+ (setq new-name (expand-file-name file new-name)))
+ (when (and (file-exists-p new-name)
+ (not (yes-or-no-p (format "%s already exists; overwrite? "
+ new-name))))
+ (user-error "Not overwriting %s" new-name))
+ (let* ((descr (archive-get-descr))
+ (archive (buffer-file-name))
+ (extractor (archive-name "extract"))
+ (ename (archive--file-desc-ext-file-name descr)))
+ (with-temp-buffer
+ (archive--extract-file extractor archive ename)
+ (write-region (point-min) (point-max) new-name))))
+
(defun archive-extract (&optional other-window-p event)
"In archive mode, extract this entry of the archive into its own buffer."
(interactive (list nil last-input-event))
@@ -1030,26 +1103,7 @@ using `make-temp-file', and the generated name is
returned."
(setq archive-subfile-mode descr)
(setq archive-file-name-coding-system file-name-coding)
(if (and
- (null
- (let (;; We may have to encode the file name argument for
- ;; external programs.
- (coding-system-for-write
- (and enable-multibyte-characters
- archive-file-name-coding-system))
- ;; We read an archive member by no-conversion at
- ;; first, then decode appropriately by calling
- ;; archive-set-buffer-as-visiting-file later.
- (coding-system-for-read 'no-conversion)
- ;; Avoid changing dir mtime by lock_file
- (create-lockfiles nil))
- (condition-case err
- (if (fboundp extractor)
- (funcall extractor archive ename)
- (archive-*-extract archive ename
- (symbol-value extractor)))
- (error
- (ding (message "%s" (error-message-string err)))
- nil))))
+ (null (archive--extract-file extractor archive ename))
just-created)
(progn
(set-buffer-modified-p nil)
@@ -1082,6 +1136,27 @@ using `make-temp-file', and the generated name is
returned."
(other-window-p (switch-to-buffer-other-window buffer))
(t (switch-to-buffer buffer))))))
+(defun archive--extract-file (extractor archive ename)
+ (let (;; We may have to encode the file name argument for
+ ;; external programs.
+ (coding-system-for-write
+ (and enable-multibyte-characters
+ archive-file-name-coding-system))
+ ;; We read an archive member by no-conversion at
+ ;; first, then decode appropriately by calling
+ ;; archive-set-buffer-as-visiting-file later.
+ (coding-system-for-read 'no-conversion)
+ ;; Avoid changing dir mtime by lock_file
+ (create-lockfiles nil))
+ (condition-case err
+ (if (fboundp extractor)
+ (funcall extractor archive ename)
+ (archive-*-extract archive ename
+ (symbol-value extractor)))
+ (error
+ (ding (message "%s" (error-message-string err)))
+ nil))))
+
(defun archive-*-extract (archive name command)
(let* ((default-directory (file-name-as-directory archive-tmpdir))
(tmpfile (expand-file-name (file-name-nondirectory name)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index de7d60f..fb293ad 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -1667,6 +1667,19 @@ Don't affect the buffer ring order."
;;;###autoload
+(defun bookmark-bmenu-get-buffer ()
+ "Return the Bookmark List, building it if it doesn't exists.
+Don't affect the buffer ring order."
+ (or (get-buffer bookmark-bmenu-buffer)
+ (save-excursion
+ (save-window-excursion
+ (bookmark-bmenu-list)
+ (get-buffer bookmark-bmenu-buffer)))))
+
+(custom-add-choice 'tab-bar-new-tab-choice
+ '(const :tag "Bookmark List" bookmark-bmenu-get-buffer))
+
+;;;###autoload
(defun bookmark-bmenu-list ()
"Display a list of existing bookmarks.
The list is displayed in a buffer named `*Bookmark List*'.
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 655a76a..aa5c47c 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -69,11 +69,26 @@ minus `Buffer-menu-size-width'. This use is deprecated."
"use `Buffer-menu-name-width' and
`Buffer-menu-size-width' instead."
"24.3")
-(defcustom Buffer-menu-name-width 19
- "Width of buffer name column in the Buffer Menu."
- :type 'number
+(defun Buffer-menu--dynamic-name-width (buffers)
+ "Return a name column width based on the current window width.
+The width will never exceed the actual width of the buffer names,
+but will never be narrower than 19 characters."
+ (max 19
+ ;; This gives 19 on an 80 column window, and take up
+ ;; proportionally more space as the window widens.
+ (min (truncate (/ (window-width) 4.2))
+ (apply #'max 0 (mapcar (lambda (b)
+ (length (buffer-name b)))
+ buffers)))))
+
+(defcustom Buffer-menu-name-width #'Buffer-menu--dynamic-name-width
+ "Width of buffer name column in the Buffer Menu.
+This can either be a number (used directly) or a function that
+will be called with the list of buffers and should return a
+number."
+ :type '(choice function number)
:group 'Buffer-menu
- :version "24.3")
+ :version "28.1")
(defcustom Buffer-menu-size-width 7
"Width of buffer size column in the Buffer Menu."
@@ -488,8 +503,9 @@ Buffers marked with
\\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted
(defun Buffer-menu-select ()
"Select this line's buffer; also, display buffers marked with `>'.
You can mark buffers with the \\<Buffer-menu-mode-map>`\\[Buffer-menu-mark]'
command.
+
This command deletes and replaces all the previously existing windows
-in the selected frame."
+in the selected frame, and will remove any marks."
(interactive)
(let* ((this-buffer (Buffer-menu-buffer t))
(menu-buffer (current-buffer))
@@ -645,25 +661,11 @@ means list those buffers and no others."
(defun list-buffers--refresh (&optional buffer-list old-buffer)
;; Set up `tabulated-list-format'.
- (let ((name-width Buffer-menu-name-width)
- (size-width Buffer-menu-size-width)
+ (let ((size-width Buffer-menu-size-width)
(marked-buffers (Buffer-menu-marked-buffers))
(buffer-menu-buffer (current-buffer))
(show-non-file (not Buffer-menu-files-only))
- entries)
- ;; Handle obsolete variable:
- (if Buffer-menu-buffer+size-width
- (setq name-width (- Buffer-menu-buffer+size-width size-width)))
- (setq tabulated-list-format
- (vector '("C" 1 t :pad-right 0)
- '("R" 1 t :pad-right 0)
- '("M" 1 t)
- `("Buffer" ,name-width t)
- `("Size" ,size-width tabulated-list-entry-size->
- :right-align t)
- `("Mode" ,Buffer-menu-mode-width t)
- '("File" 1 t)))
- (setq tabulated-list-use-header-line Buffer-menu-use-header-line)
+ entries name-width)
;; Collect info for each buffer we're interested in.
(dolist (buffer (or buffer-list
(buffer-list (if Buffer-menu-use-frame-buffer-list
@@ -693,6 +695,22 @@ means list those buffers and no others."
nil nil buffer)))
(Buffer-menu--pretty-file-name file)))
entries)))))
+ (setq name-width (if (functionp Buffer-menu-name-width)
+ (funcall Buffer-menu-name-width (mapcar #'car
entries))
+ Buffer-menu-name-width))
+ ;; Handle obsolete variable:
+ (if Buffer-menu-buffer+size-width
+ (setq name-width (- Buffer-menu-buffer+size-width size-width)))
+ (setq tabulated-list-format
+ (vector '("C" 1 t :pad-right 0)
+ '("R" 1 t :pad-right 0)
+ '("M" 1 t)
+ `("Buffer" ,name-width t)
+ `("Size" ,size-width tabulated-list-entry-size->
+ :right-align t)
+ `("Mode" ,Buffer-menu-mode-width t)
+ '("File" 1 t)))
+ (setq tabulated-list-use-header-line Buffer-menu-use-header-line)
(setq tabulated-list-entries (nreverse entries)))
(tabulated-list-init-header))
diff --git a/lisp/button.el b/lisp/button.el
index d9c36a0..03ab59b 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -464,8 +464,12 @@ see).
POS defaults to point, except when `push-button' is invoked
interactively as the result of a mouse-event, in which case, the
mouse event is used.
+
If there's no button at POS, do nothing and return nil, otherwise
-return t."
+return t.
+
+To get a description of what function will called when pushing a
+butting, use the `button-describe' command."
(interactive
(list (if (integerp last-command-event) (point) last-command-event)))
(if (and (not (integerp pos)) (eventp pos))
@@ -555,6 +559,51 @@ Returns the button found."
(interactive "p\nd\nd")
(forward-button (- n) wrap display-message no-error))
+(defun button--describe (properties)
+ "Describe a button's PROPERTIES (an alist) in a *Help* buffer.
+This is a helper function for `button-describe', in order to be possible to
+use `help-setup-xref'.
+
+Each element of PROPERTIES should be of the form (PROPERTY . VALUE)."
+ (help-setup-xref (list #'button--describe properties)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert (format-message "This button's type is `%s'."
+ (alist-get 'type properties)))
+ (dolist (prop '(action mouse-action))
+ (let ((name (symbol-name prop))
+ (val (alist-get prop properties)))
+ (when (functionp val)
+ (insert "\n\n"
+ (propertize (capitalize name) 'face 'bold)
+ "\nThe " name " of this button is")
+ (if (symbolp val)
+ (progn
+ (insert (format-message " `%s',\nwhich is " val))
+ (describe-function-1 val))
+ (insert "\n")
+ (princ val))))))))
+
+(defun button-describe (&optional button-or-pos)
+ "Display a buffer with information about the button at point.
+
+When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a
+buffer position where a button is present. If BUTTON-OR-POS is nil, the
+button at point is the button to describe."
+ (interactive "d")
+ (let* ((button (cond ((integer-or-marker-p button-or-pos)
+ (button-at button-or-pos))
+ ((null button-or-pos) (button-at (point)))
+ ((overlayp button-or-pos) button-or-pos)))
+ (props (and button
+ (mapcar (lambda (prop)
+ (cons prop (button-get button prop)))
+ '(type action mouse-action)))))
+ (when props
+ (button--describe props)
+ t)))
+
(provide 'button)
;;; button.el ends here
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index 3db12e6..af6acaf 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -350,17 +350,29 @@ If the locale never uses daylight saving time, set this
to 0."
:group 'calendar-dst)
(defcustom calendar-standard-time-zone-name
- (or (nth 2 calendar-current-time-zone-cache) "EST")
+ (if calendar-use-numeric-time-zones
+ (if calendar-current-time-zone-cache
+ (format-time-string
+ "%z" 0 (* 60 (car calendar-current-time-zone-cache)))
+ "+0000")
+ (or (nth 2 calendar-current-time-zone-cache) "EST"))
"Abbreviated name of standard time zone at `calendar-location-name'.
For example, \"EST\" in New York City, \"PST\" for Los Angeles."
:type 'string
+ :version "28.1"
:group 'calendar-dst)
(defcustom calendar-daylight-time-zone-name
- (or (nth 3 calendar-current-time-zone-cache) "EDT")
+ (if calendar-use-numeric-time-zones
+ (if calendar-current-time-zone-cache
+ (format-time-string
+ "%z" 0 (* 60 (cadr calendar-current-time-zone-cache)))
+ "+0000")
+ (or (nth 3 calendar-current-time-zone-cache) "EDT"))
"Abbreviated name of daylight saving time zone at `calendar-location-name'.
For example, \"EDT\" in New York City, \"PDT\" for Los Angeles."
:type 'string
+ :version "28.1"
:group 'calendar-dst)
(defcustom calendar-daylight-savings-starts-time
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 1d5b947..0efb2bc 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -1061,6 +1061,13 @@ calendar."
:type 'boolean
:group 'holidays)
+(defcustom calendar-use-numeric-time-zones nil
+ "If nil, use symbolic time zones like \"CET\" when displaying dates.
+If non-nil, use numeric time zones like \"+0100\"."
+ :type 'boolean
+ :version "28.1"
+ :group 'calendar)
+
;;; End of user options.
(calendar-recompute-layout-variables)
diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el
index 6a813e9..635bdd8 100644
--- a/lisp/calendar/solar.el
+++ b/lisp/calendar/solar.el
@@ -209,7 +209,6 @@ Returns nil if nothing was entered."
(defun solar-setup ()
"Prompt for `calendar-longitude', `calendar-latitude', `calendar-time-zone'."
- (beep)
(or calendar-longitude
(setq calendar-longitude
(solar-get-number
@@ -840,7 +839,9 @@ This function is suitable for execution in an init file."
"E" "W"))))))
(calendar-standard-time-zone-name
(if (< arg 16) calendar-standard-time-zone-name
- (cond ((zerop calendar-time-zone) "UTC")
+ (cond ((zerop calendar-time-zone)
+ (if calendar-use-numeric-time-zones
+ "+0100" "UTC"))
((< calendar-time-zone 0)
(format "UTC%dmin" calendar-time-zone))
(t (format "UTC+%dmin" calendar-time-zone)))))
@@ -1013,7 +1014,10 @@ Requires floating point."
(let* ((m displayed-month)
(y displayed-year)
(calendar-standard-time-zone-name
- (if calendar-time-zone calendar-standard-time-zone-name "UTC"))
+ (cond
+ (calendar-time-zone calendar-standard-time-zone-name)
+ (calendar-use-numeric-time-zones "+0100")
+ (t "UTC")))
(calendar-daylight-savings-starts
(if calendar-time-zone calendar-daylight-savings-starts))
(calendar-daylight-savings-ends
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index eeb0992..125f9ac 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -527,6 +527,21 @@ TIME is modified and returned."
time)
+(defun decoded-time-period (time)
+ "Interpret DECODED as a period and return its length in seconds.
+For computational purposes, years are 365 days long and months
+are 30 days long."
+ (+ (if (consp (decoded-time-second time))
+ ;; Fractional second.
+ (/ (float (car (decoded-time-second time)))
+ (cdr (decoded-time-second time)))
+ (or (decoded-time-second time) 0))
+ (* (or (decoded-time-minute time) 0) 60)
+ (* (or (decoded-time-hour time) 0) 60 60)
+ (* (or (decoded-time-day time) 0) 60 60 24)
+ (* (or (decoded-time-month time) 0) 60 60 24 30)
+ (* (or (decoded-time-year time) 0) 60 60 24 365)))
+
(provide 'time-date)
;;; time-date.el ends here
diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el
index e2c2ebe..7c60916 100644
--- a/lisp/cus-dep.el
+++ b/lisp/cus-dep.el
@@ -70,7 +70,7 @@ Usage: emacs -batch -l ./cus-dep.el -f
custom-make-dependencies DIRS"
(directory-files subdir nil
"\\`[^=.].*\\.el\\'"))))
(progress (make-progress-reporter
- (byte-compile-info-string "Scanning files for custom")
+ (byte-compile-info "Scanning files for custom")
0 (length files) nil 10)))
(with-temp-buffer
(dolist (elem files)
@@ -128,8 +128,8 @@ Usage: emacs -batch -l ./cus-dep.el -f
custom-make-dependencies DIRS"
type)))))))))))
(error nil)))))))
(progress-reporter-done progress))
- (byte-compile-info-message "Generating %s..."
- generated-custom-dependencies-file)
+ (byte-compile-info
+ (format "Generating %s..." generated-custom-dependencies-file) t)
(set-buffer (find-file-noselect generated-custom-dependencies-file))
(setq buffer-undo-list t)
(erase-buffer)
@@ -218,8 +218,8 @@ elements the files that have variables or faces that
contain that
version. These files should be loaded before showing the customization
buffer that `customize-changed-options' generates.\")\n\n"))
(save-buffer)
- (byte-compile-info-message "Generating %s...done"
- generated-custom-dependencies-file))
+ (byte-compile-info
+ (format "Generating %s...done" generated-custom-dependencies-file) t))
(provide 'cus-dep)
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 1942f25..1669596 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -4841,7 +4841,10 @@ The format is suitable for use with `easy-menu-define'."
(error "You can't edit this part of the Custom buffer"))
(defun Custom-newline (pos &optional event)
- "Invoke button at POS, or refuse to allow editing of Custom buffer."
+ "Invoke button at POS, or refuse to allow editing of Custom buffer.
+
+To see what function the widget will call, use the
+`widget-describe' command."
(interactive "@d")
(let ((button (get-char-property pos 'button)))
;; If there is no button at point, then use the one at the start
diff --git a/lisp/custom.el b/lisp/custom.el
index 885c486..db7f6a0 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -1541,6 +1541,20 @@ Each of the arguments ARGS has this form:
This means reset VARIABLE. (The argument IGNORED is ignored)."
(apply #'custom-theme-reset-variables 'user args))
+(defun custom-add-choice (variable choice)
+ "Add CHOICE to the custom type of VARIABLE.
+If a choice with the same tag already exists, no action is taken."
+ (let ((choices (get variable 'custom-type)))
+ (unless (eq (car choices) 'choice)
+ (error "Not a choice type: %s" choices))
+ (unless (seq-find (lambda (elem)
+ (equal (caddr (member :tag elem))
+ (caddr (member :tag choice))))
+ (cdr choices))
+ ;; Put the new choice at the end.
+ (put variable 'custom-type
+ (append choices (list choice))))))
+
;;; The End.
(provide 'custom)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index efb2140..84d8c36 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -688,7 +688,7 @@ are executed in the background on each file sequentially
waiting
for each command to terminate before running the next command.
In shell syntax this means separating the individual commands with `;'.
-The output appears in the buffer `*Async Shell Command*'."
+The output appears in the buffer `shell-command-buffer-name-async'."
(interactive
(let ((files (dired-get-marked-files t current-prefix-arg nil nil t)))
(list
@@ -727,7 +727,7 @@ it, write `*\"\"' in place of just `*'. This is equivalent
to just
If COMMAND ends in `&', `;', or `;&', it is executed in the
background asynchronously, and the output appears in the buffer
-`*Async Shell Command*'. When operating on multiple files and COMMAND
+`shell-command-buffer-name-async'. When operating on multiple files and
COMMAND
ends in `&', the shell command is executed on each file in parallel.
However, when COMMAND ends in `;' or `;&' then commands are executed
in the background on each file sequentially waiting for each command
@@ -735,7 +735,7 @@ to terminate before running the next command. You can also
use
`dired-do-async-shell-command' that automatically adds `&'.
Otherwise, COMMAND is executed synchronously, and the output
-appears in the buffer `*Shell Command Output*'.
+appears in the buffer `shell-command-buffer-name'.
This feature does not try to redisplay Dired buffers afterward, as
there's no telling what files COMMAND may have changed.
@@ -952,13 +952,17 @@ With a prefix argument, kill that many lines starting
with the current line.
"Kill all marked lines (not the files).
With a prefix argument, kill that many lines starting with the current line.
\(A negative argument kills backward.)
+
If you use this command with a prefix argument to kill the line
for a file that is a directory, which you have inserted in the
Dired buffer as a subdirectory, then it deletes that subdirectory
from the buffer as well.
+
To kill an entire subdirectory \(without killing its line in the
parent directory), go to its directory header line and use this
-command with a prefix argument (the value does not matter)."
+command with a prefix argument (the value does not matter).
+
+To undo the killing, the undo command can be used as normally."
;; Returns count of killed lines. FMT="" suppresses message.
(interactive "P")
(if arg
@@ -1010,8 +1014,8 @@ command with a prefix argument (the value does not
matter)."
(defvar dired-compress-file-suffixes
'(
;; "tar -zxf" isn't used because it's not available on the
- ;; Solaris10 version of tar. Solaris10 becomes obsolete in 2021.
- ;; Same thing on AIX 7.1.
+ ;; Solaris 10 version of tar (obsolete in 2024?).
+ ;; Same thing on AIX 7.1 (obsolete 2023?) and 7.2 (obsolete 2022?).
("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf -")
("\\.tgz\\'" "" "gzip -dc %i | tar -xf -")
("\\.gz\\'" "" "gunzip")
@@ -1974,6 +1978,10 @@ Optional arg HOW-TO determines how to treat the target.
(apply (car into-dir) operation rfn-list fn-list target (cdr into-dir))
(if (not (or dired-one-file into-dir))
(error "Marked %s: target must be a directory: %s" operation target))
+ (if (and (not (file-directory-p (car fn-list)))
+ (not (file-directory-p target))
+ (directory-name-p target))
+ (error "%s: Target directory does not exist: %s" operation target))
;; rename-file bombs when moving directories unless we do this:
(or into-dir (setq target (directory-file-name target)))
(dired-create-files
diff --git a/lisp/dired.el b/lisp/dired.el
index 1792250..d19d6d1 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -125,7 +125,7 @@ For more details, see Info node `(emacs)ls in Lisp'."
"Informs Dired about how `ls -lF' marks symbolic links.
Set this to t if `ls' (or whatever program is specified by
`insert-directory-program') with `-lF' marks the symbolic link
-itself with a trailing @ (usually the case under Ultrix).
+itself with a trailing @ (usually the case under Ultrix and macOS).
Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to
nil (the default), if it gives `bar@ -> foo', set it to t.
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index d9da365..05eb0ac 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1126,7 +1126,7 @@ write its autoloads into the specified file instead."
;; Elements remaining in FILES have no existing autoload sections yet.
(let ((no-autoloads-time (or last-time '(0 0 0 0)))
(progress (make-progress-reporter
- (byte-compile-info-string
+ (byte-compile-info
(concat "Scraping files for "
(file-relative-name
generated-autoload-file)))
@@ -1169,6 +1169,19 @@ write its autoloads into the specified file instead."
;; file-local autoload-generated-file settings.
(autoload-save-buffers))))
+(defun batch-update-autoloads--summary (strings)
+ (let ((message ""))
+ (while strings
+ (when (> (length (concat message " " (car strings))) 64)
+ (byte-compile-info (concat message " ...") t "SCRAPE")
+ (setq message ""))
+ (setq message (if (zerop (length message))
+ (car strings)
+ (concat message " " (car strings))))
+ (setq strings (cdr strings)))
+ (when (> (length message) 0)
+ (byte-compile-info message t "SCRAPE"))))
+
;;;###autoload
(defun batch-update-autoloads ()
"Update loaddefs.el autoloads in batch mode.
@@ -1192,6 +1205,7 @@ should be non-nil)."
(or (string-match "\\`site-" file)
(push (expand-file-name file) autoload-excludes)))))))
(let ((args command-line-args-left))
+ (batch-update-autoloads--summary args)
(setq command-line-args-left nil)
(apply #'update-directory-autoloads args)))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 0d9c449..4987596 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -648,14 +648,23 @@
(setq args (cons (car rest) args)))
(setq rest (cdr rest)))
(if (cdr constants)
- (if args
- (list (car form)
- (apply (car form) constants)
- (if (cdr args)
- (cons (car form) (nreverse args))
- (car args)))
- (apply (car form) constants))
- form)))
+ (let ((const (apply (car form) (nreverse constants))))
+ (if args
+ (append (list (car form) const)
+ (nreverse args))
+ const))
+ form)))
+
+(defun byte-optimize-min-max (form)
+ "Optimize `min' and `max'."
+ (let ((opt (byte-optimize-associative-math form)))
+ (if (and (consp opt) (memq (car opt) '(min max))
+ (= (length opt) 4))
+ ;; (OP x y z) -> (OP (OP x y) z), in order to use binary byte ops.
+ (list (car opt)
+ (list (car opt) (nth 1 opt) (nth 2 opt))
+ (nth 3 opt))
+ opt)))
;; Use OP to reduce any leading prefix of constant numbers in the list
;; (cons ACCUM ARGS) down to a single number, and return the
@@ -878,8 +887,8 @@
(put '* 'byte-optimizer #'byte-optimize-multiply)
(put '- 'byte-optimizer #'byte-optimize-minus)
(put '/ 'byte-optimizer #'byte-optimize-divide)
-(put 'max 'byte-optimizer #'byte-optimize-associative-math)
-(put 'min 'byte-optimizer #'byte-optimize-associative-math)
+(put 'max 'byte-optimizer #'byte-optimize-min-max)
+(put 'min 'byte-optimizer #'byte-optimize-min-max)
(put '= 'byte-optimizer #'byte-optimize-binary-predicate)
(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 5398466..8c16c17 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -587,13 +587,26 @@ Otherwise, return nil. For internal use only."
(mapconcat (lambda (char) (format "`?\\%c'" char))
sorted ", ")))))
+(defun byte-compile-info (string &optional message type)
+ "Format STRING in a way that looks pleasing in the compilation output.
+If MESSAGE, output the message, too.
+
+If TYPE, it should be a string that says what the information
+type is. This defaults to \"INFO\"."
+ (let ((string (format " %-9s%s" (or type "INFO") string)))
+ (when message
+ (message "%s" string))
+ string))
+
(defun byte-compile-info-string (&rest args)
"Format ARGS in a way that looks pleasing in the compilation output."
- (format " %-9s%s" "INFO" (apply #'format args)))
+ (declare (obsolete byte-compile-info "28.1"))
+ (byte-compile-info (apply #'format args)))
(defun byte-compile-info-message (&rest args)
"Message format ARGS in a way that looks pleasing in the compilation output."
- (message "%s" (apply #'byte-compile-info-string args)))
+ (declare (obsolete byte-compile-info "28.1"))
+ (byte-compile-info (apply #'format args) t))
;; I nuked this because it's not a good idea for users to think of using it.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 7a56aa2..c5b086f 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -3659,10 +3659,10 @@ If it is nil, then the handler is
\"byte-compile-SYMBOL.\""
(byte-defop-compiler (% byte-rem) 2)
(byte-defop-compiler aset 3)
-(byte-defop-compiler max byte-compile-associative)
-(byte-defop-compiler min byte-compile-associative)
-(byte-defop-compiler (+ byte-plus) byte-compile-associative)
-(byte-defop-compiler (* byte-mult) byte-compile-associative)
+(byte-defop-compiler max byte-compile-min-max)
+(byte-defop-compiler min byte-compile-min-max)
+(byte-defop-compiler (+ byte-plus) byte-compile-variadic-numeric)
+(byte-defop-compiler (* byte-mult) byte-compile-variadic-numeric)
;;####(byte-defop-compiler move-to-column 1)
(byte-defop-compiler-1 interactive byte-compile-noop)
@@ -3809,30 +3809,36 @@ discarding."
(if byte-compile--for-effect (setq byte-compile--for-effect nil)
(byte-compile-out 'byte-constant (nth 1 form))))
-;; Compile a function that accepts one or more args and is right-associative.
-;; We do it by left-associativity so that the operations
-;; are done in the same order as in interpreted code.
-;; We treat the one-arg case, as in (+ x), like (+ x 0).
-;; in order to convert markers to numbers, and trigger expected errors.
-(defun byte-compile-associative (form)
+;; Compile a pure function that accepts zero or more numeric arguments
+;; and has an opcode for the binary case.
+;; Single-argument calls are assumed to be numeric identity and are
+;; compiled as (* x 1) in order to convert markers to numbers and
+;; trigger type errors.
+(defun byte-compile-variadic-numeric (form)
+ (pcase (length form)
+ (1
+ ;; No args: use the identity value for the operation.
+ (byte-compile-constant (eval form)))
+ (2
+ ;; One arg: compile (OP x) as (* x 1). This is identity for
+ ;; all numerical values including -0.0, infinities and NaNs.
+ (byte-compile-form (nth 1 form))
+ (byte-compile-constant 1)
+ (byte-compile-out (get '* 'byte-opcode) 0))
+ (3
+ (byte-compile-form (nth 1 form))
+ (byte-compile-form (nth 2 form))
+ (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (_
+ ;; >2 args: compile as a single function call.
+ (byte-compile-normal-call form))))
+
+(defun byte-compile-min-max (form)
+ "Byte-compile calls to `min' or `max'."
(if (cdr form)
- (let ((opcode (get (car form) 'byte-opcode))
- args)
- (if (and (< 3 (length form))
- (memq opcode (list (get '+ 'byte-opcode)
- (get '* 'byte-opcode))))
- ;; Don't use binary operations for > 2 operands, as that
- ;; may cause overflow/truncation in float operations.
- (byte-compile-normal-call form)
- (setq args (copy-sequence (cdr form)))
- (byte-compile-form (car args))
- (setq args (cdr args))
- (or args (setq args '(0)
- opcode (get '+ 'byte-opcode)))
- (dolist (arg args)
- (byte-compile-form arg)
- (byte-compile-out opcode 0))))
- (byte-compile-constant (eval form))))
+ (byte-compile-variadic-numeric form)
+ ;; No args: warn and emit code that raises an error when executed.
+ (byte-compile-normal-call form)))
;; more complicated compiler macros
@@ -3847,7 +3853,7 @@ discarding."
(byte-defop-compiler indent-to)
(byte-defop-compiler insert)
(byte-defop-compiler-1 function byte-compile-function-form)
-(byte-defop-compiler-1 - byte-compile-minus)
+(byte-defop-compiler (- byte-diff) byte-compile-minus)
(byte-defop-compiler (/ byte-quo) byte-compile-quo)
(byte-defop-compiler nconc)
@@ -3914,30 +3920,17 @@ discarding."
((byte-compile-normal-call form)))))
(defun byte-compile-minus (form)
- (let ((len (length form)))
- (cond
- ((= 1 len) (byte-compile-constant 0))
- ((= 2 len)
- (byte-compile-form (cadr form))
- (byte-compile-out 'byte-negate 0))
- ((= 3 len)
- (byte-compile-form (nth 1 form))
- (byte-compile-form (nth 2 form))
- (byte-compile-out 'byte-diff 0))
- ;; Don't use binary operations for > 2 operands, as that may
- ;; cause overflow/truncation in float operations.
- (t (byte-compile-normal-call form)))))
+ (if (/= (length form) 2)
+ (byte-compile-variadic-numeric form)
+ (byte-compile-form (cadr form))
+ (byte-compile-out 'byte-negate 0)))
(defun byte-compile-quo (form)
- (let ((len (length form)))
- (cond ((< len 2)
- (byte-compile-subr-wrong-args form "1 or more"))
- ((= len 3)
- (byte-compile-two-args form))
- (t
- ;; Don't use binary operations for > 2 operands, as that
- ;; may cause overflow/truncation in float operations.
- (byte-compile-normal-call form)))))
+ (if (= (length form) 3)
+ (byte-compile-two-args form)
+ ;; N-ary `/' is not the left-reduction of binary `/' because if any
+ ;; argument is a float, then everything is done in floating-point.
+ (byte-compile-normal-call form)))
(defun byte-compile-nconc (form)
(let ((len (length form)))
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 4e8423e..02da07d 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -211,7 +211,16 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
[&rest [&or
("declare" &rest sexp)
(":argument-precedence-order" &rest sexp)
- (&define ":method" [&rest atom]
+ (&define ":method"
+ ;; FIXME: The `:unique'
+ ;; construct works around
+ ;; Bug#42672. We'd rather want
+ ;; names like those generated by
+ ;; `cl-defmethod', but that
+ ;; requires larger changes to
+ ;; Edebug.
+ :unique "cl-generic-:method@"
+ [&rest cl-generic-method-qualifier]
cl-generic-method-args lambda-doc
def-body)]]
def-body)))
@@ -432,9 +441,8 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(&define ; this means we are defining something
[&or name ("setf" name :name setf)]
;; ^^ This is the methods symbol
- [ &rest atom ] ; Multiple qualifiers are allowed.
- ; Like in CLOS spec, we support
- ; any non-list values.
+ [ &rest cl-generic-method-qualifier ]
+ ;; Multiple qualifiers are allowed.
cl-generic-method-args ; arguments
lambda-doc ; documentation string
def-body))) ; part to be debugged
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 6c1426c..c38019d 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2016,7 +2016,12 @@ info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
- (debug ((&rest [&or (&define name function-form) (cl-defun)])
+ (debug ((&rest [&or (&define name :unique "cl-flet@" function-form)
+ (&define name :unique "cl-flet@"
+ cl-lambda-list
+ cl-declarations-or-string
+ [&optional ("interactive" interactive)]
+ def-body)])
cl-declarations body)))
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index a565e8f..d9bbf61 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1240,6 +1240,13 @@ purpose by adding an entry to this alist, and setting
;; since it wraps the list of forms with a call to `edebug-enter'.
;; Uses the dynamically bound vars edebug-def-name and edebug-def-args.
;; Do this after parsing since that may find a name.
+ (when (string-match-p (rx bos "edebug-anon" (+ digit) eos)
+ (symbol-name edebug-old-def-name))
+ ;; FIXME: Due to Bug#42701, we reset an anonymous name so that
+ ;; backtracking doesn't generate duplicate definitions. It would
+ ;; be better to not define wrappers in the case of a non-matching
+ ;; specification branch to begin with.
+ (setq edebug-old-def-name nil))
(setq edebug-def-name
(or edebug-def-name edebug-old-def-name (gensym "edebug-anon")))
`(edebug-enter
@@ -1725,12 +1732,15 @@ contains a circular object."
(&define . edebug-match-&define)
(name . edebug-match-name)
(:name . edebug-match-colon-name)
+ (:unique . edebug-match-:unique)
(arg . edebug-match-arg)
(def-body . edebug-match-def-body)
(def-form . edebug-match-def-form)
;; Less frequently used:
;; (function . edebug-match-function)
(lambda-expr . edebug-match-lambda-expr)
+ (cl-generic-method-qualifier
+ . edebug-match-cl-generic-method-qualifier)
(cl-generic-method-args . edebug-match-cl-generic-method-args)
(cl-macrolet-expr . edebug-match-cl-macrolet-expr)
(cl-macrolet-name . edebug-match-cl-macrolet-name)
@@ -2035,6 +2045,27 @@ contains a circular object."
spec))
nil)
+(defun edebug-match-:unique (_cursor spec)
+ "Match a `:unique PREFIX' specifier.
+SPEC is the symbol name prefix for `gensym'."
+ (let ((suffix (gensym spec)))
+ (setq edebug-def-name
+ (if edebug-def-name
+ ;; Construct a new name by appending to previous name.
+ (intern (format "%s@%s" edebug-def-name suffix))
+ suffix)))
+ nil)
+
+(defun edebug-match-cl-generic-method-qualifier (cursor)
+ "Match a QUALIFIER for `cl-defmethod' at CURSOR."
+ (let ((args (edebug-top-element-required cursor "Expected qualifier")))
+ ;; Like in CLOS spec, we support any non-list values.
+ (unless (atom args) (edebug-no-match cursor "Atom expected"))
+ ;; Append the arguments to `edebug-def-name' (Bug#42671).
+ (setq edebug-def-name (intern (format "%s %s" edebug-def-name args)))
+ (edebug-move-cursor cursor)
+ (list args)))
+
(defun edebug-match-cl-generic-method-args (cursor)
(let ((args (edebug-top-element-required cursor "Expected arguments")))
(if (not (consp args))
diff --git a/lisp/emacs-lisp/hierarchy.el b/lisp/emacs-lisp/hierarchy.el
new file mode 100644
index 0000000..8cef029
--- /dev/null
+++ b/lisp/emacs-lisp/hierarchy.el
@@ -0,0 +1,579 @@
+;;; hierarchy.el --- Library to create and display hierarchy structures -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Damien Cassou <damien@cassou.me>
+;; Maintainer: emacs-devel@gnu.org
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Library to create, query, navigate and display hierarchy structures.
+
+;; Creation: After having created a hierarchy with `hierarchy-new',
+;; populate it by calling `hierarchy-add-tree' or
+;; `hierarchy-add-trees'. You can then optionally sort its element
+;; with `hierarchy-sort'.
+
+;; Querying: You can learn more about your hierarchy by using
+;; functions such as `hierarchy-roots', `hierarchy-has-item',
+;; `hierarchy-length', `hierarchy-parent', `hierarchy-descendant-p'.
+
+;; Navigation: When your hierarchy is ready, you can use
+;; `hierarchy-map-item', `hierarchy-map', and `map-tree' to apply
+;; functions to elements of the hierarchy.
+
+;; Display: You can display a hierarchy as a tabulated list using
+;; `hierarchy-tabulated-display' and as an expandable/foldable tree
+;; using `hierarchy-convert-to-tree-widget'. The
+;; `hierarchy-labelfn-*' functions will help you display each item of
+;; the hierarchy the way you want it.
+
+;;; Limitation:
+
+;; - Current implementation uses #'equal to find and distinguish
+;; elements. Support for user-provided equality definition is
+;; desired but not yet implemented;
+;;
+;; - nil can't be added to a hierarchy;
+;;
+;; - the hierarchy is computed eagerly.
+
+;;; Code:
+
+(require 'seq)
+(require 'map)
+(require 'subr-x)
+(require 'cl-lib)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(cl-defstruct (hierarchy
+ (:constructor hierarchy--make)
+ (:conc-name hierarchy--))
+ (roots (list)) ; list of the hierarchy roots (no parent)
+ (parents (make-hash-table :test 'equal)) ; map an item to its parent
+ (children (make-hash-table :test 'equal)) ; map an item to its childre
+ ;; cache containing the set of all items in the hierarchy
+ (seen-items (make-hash-table :test 'equal))) ; map an item to t
+
+(defun hierarchy--seen-items-add (hierarchy item)
+ "In HIERARCHY, add ITEM to seen items."
+ (map-put! (hierarchy--seen-items hierarchy) item t))
+
+(defun hierarchy--compute-roots (hierarchy)
+ "Search roots of HIERARCHY and return them."
+ (cl-set-difference
+ (map-keys (hierarchy--seen-items hierarchy))
+ (map-keys (hierarchy--parents hierarchy))
+ :test #'equal))
+
+(defun hierarchy--sort-roots (hierarchy sortfn)
+ "Compute, sort and store the roots of HIERARCHY.
+
+SORTFN is a function taking two items of the hierarchy as parameter and
+returning non-nil if the first parameter is lower than the second."
+ (setf (hierarchy--roots hierarchy)
+ (sort (hierarchy--compute-roots hierarchy)
+ sortfn)))
+
+(defun hierarchy--add-relation (hierarchy item parent acceptfn)
+ "In HIERARCHY, add ITEM as child of PARENT.
+
+ACCEPTFN is a function returning non-nil if its parameter (any object)
+should be an item of the hierarchy."
+ (let* ((existing-parent (hierarchy-parent hierarchy item))
+ (has-parent-p (funcall acceptfn existing-parent)))
+ (cond
+ ((and has-parent-p (not (equal existing-parent parent)))
+ (error "An item (%s) can only have one parent: '%s' vs '%s'"
+ item existing-parent parent))
+ ((not has-parent-p)
+ (let ((existing-children (map-elt (hierarchy--children hierarchy)
+ parent (list))))
+ (map-put! (hierarchy--children hierarchy)
+ parent (append existing-children (list item))))
+ (map-put! (hierarchy--parents hierarchy) item parent)))))
+
+(defun hierarchy--set-equal (list1 list2 &rest cl-keys)
+ "Return non-nil if LIST1 and LIST2 have same elements.
+
+I.e., if every element of LIST1 also appears in LIST2 and if
+every element of LIST2 also appears in LIST1.
+
+CL-KEYS are key-value pairs just like in `cl-subsetp'. Supported
+keys are :key and :test."
+ (and (apply 'cl-subsetp list1 list2 cl-keys)
+ (apply 'cl-subsetp list2 list1 cl-keys)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Creation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-new ()
+ "Create a hierarchy and return it."
+ (hierarchy--make))
+
+(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn
acceptfn)
+ "In HIERARCHY, add ITEM.
+
+PARENTFN is either nil or a function defining the child-to-parent
+relationship: this function takes an item as parameter and should return
+the parent of this item in the hierarchy. If the item has no parent in the
+hierarchy (i.e., it should be a root), the function should return an object
+not accepted by acceptfn (i.e., nil for the default value of acceptfn).
+
+CHILDRENFN is either nil or a function defining the parent-to-children
+relationship: this function takes an item as parameter and should return a
+list of children of this item in the hierarchy.
+
+If both PARENTFN and CHILDRENFN are non-nil, the results of PARENTFN and
+CHILDRENFN are expected to be coherent with each other.
+
+ACCEPTFN is a function returning non-nil if its parameter (any object)
+should be an item of the hierarchy. By default, ACCEPTFN returns non-nil
+if its parameter is non-nil."
+ (unless (hierarchy-has-item hierarchy item)
+ (let ((acceptfn (or acceptfn #'identity)))
+ (hierarchy--seen-items-add hierarchy item)
+ (let ((parent (and parentfn (funcall parentfn item))))
+ (when (funcall acceptfn parent)
+ (hierarchy--add-relation hierarchy item parent acceptfn)
+ (hierarchy-add-tree hierarchy parent parentfn childrenfn)))
+ (let ((children (and childrenfn (funcall childrenfn item))))
+ (mapc (lambda (child)
+ (when (funcall acceptfn child)
+ (hierarchy--add-relation hierarchy child item acceptfn)
+ (hierarchy-add-tree hierarchy child parentfn childrenfn)))
+ children)))))
+
+(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn
acceptfn)
+ "Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS.
+
+PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'."
+ (seq-map (lambda (item)
+ (hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn))
+ items))
+
+(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn)
+ "Add to HIERARCHY the sub-lists in LIST.
+
+If WRAP is non-nil, allow duplicate items in LIST by wraping each
+item in a cons (id . item). The root's id is 1.
+
+CHILDRENFN is a function (defaults to `cdr') taking LIST as a
+parameter which should return LIST's children (a list). Each
+child is (recursively) passed as a parameter to CHILDRENFN to get
+its own children. Because of this parameter, LIST can be
+anything, not necessarily a list."
+ (let* ((childrenfn (or childrenfn #'cdr))
+ (id 0)
+ (wrapfn (lambda (item)
+ (if wrap
+ (cons (setq id (1+ id)) item)
+ item)))
+ (unwrapfn (if wrap #'cdr #'identity)))
+ (hierarchy-add-tree
+ hierarchy (funcall wrapfn list) nil
+ (lambda (item)
+ (mapcar wrapfn (funcall childrenfn
+ (funcall unwrapfn item)))))
+ hierarchy))
+
+(defun hierarchy-from-list (list &optional wrap childrenfn)
+ "Create and return a hierarchy built from LIST.
+
+This function passes LIST, WRAP and CHILDRENFN unchanged to
+`hierarchy-add-list'."
+ (hierarchy-add-list (hierarchy-new) list wrap childrenfn))
+
+(defun hierarchy-sort (hierarchy &optional sortfn)
+ "Modify HIERARCHY so that its roots and item's children are sorted.
+
+SORTFN is a function taking two items of the hierarchy as parameter and
+returning non-nil if the first parameter is lower than the second. By
+default, SORTFN is `string-lessp'."
+ (let ((sortfn (or sortfn #'string-lessp)))
+ (hierarchy--sort-roots hierarchy sortfn)
+ (mapc (lambda (parent)
+ (setf
+ (map-elt (hierarchy--children hierarchy) parent)
+ (sort (map-elt (hierarchy--children hierarchy) parent) sortfn)))
+ (map-keys (hierarchy--children hierarchy)))))
+
+(defun hierarchy-extract-tree (hierarchy item)
+ "Return a copy of HIERARCHY with ITEM's descendants and parents."
+ (if (not (hierarchy-has-item hierarchy item))
+ nil
+ (let ((tree (hierarchy-new)))
+ (hierarchy-add-tree tree item
+ (lambda (each) (hierarchy-parent hierarchy each))
+ (lambda (each)
+ (when (or (equal each item)
+ (hierarchy-descendant-p hierarchy each
item))
+ (hierarchy-children hierarchy each))))
+ tree)))
+
+(defun hierarchy-copy (hierarchy)
+ "Return a copy of HIERARCHY.
+
+Items in HIERARCHY are shared, but structure is not."
+ (hierarchy-map-hierarchy (lambda (item _) (identity item)) hierarchy))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Querying
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-items (hierarchy)
+ "Return a list of all items of HIERARCHY."
+ (map-keys (hierarchy--seen-items hierarchy)))
+
+(defun hierarchy-has-item (hierarchy item)
+ "Return t if HIERARCHY includes ITEM."
+ (map-contains-key (hierarchy--seen-items hierarchy) item))
+
+(defun hierarchy-empty-p (hierarchy)
+ "Return t if HIERARCHY is empty."
+ (= 0 (hierarchy-length hierarchy)))
+
+(defun hierarchy-length (hierarchy)
+ "Return the number of items in HIERARCHY."
+ (hash-table-count (hierarchy--seen-items hierarchy)))
+
+(defun hierarchy-has-root (hierarchy item)
+ "Return t if one of HIERARCHY's roots is ITEM.
+
+A root is an item with no parent."
+ (seq-contains-p (hierarchy-roots hierarchy) item))
+
+(defun hierarchy-roots (hierarchy)
+ "Return all roots of HIERARCHY.
+
+A root is an item with no parent."
+ (let ((roots (hierarchy--roots hierarchy)))
+ (or roots
+ (hierarchy--compute-roots hierarchy))))
+
+(defun hierarchy-leafs (hierarchy &optional node)
+ "Return all leafs of HIERARCHY.
+
+A leaf is an item with no child.
+
+If NODE is an item of HIERARCHY, only return leafs under NODE."
+ (let ((leafs (cl-set-difference
+ (map-keys (hierarchy--seen-items hierarchy))
+ (map-keys (hierarchy--children hierarchy)))))
+ (if (hierarchy-has-item hierarchy node)
+ (seq-filter (lambda (item)
+ (hierarchy-descendant-p hierarchy item node))
+ leafs)
+ leafs)))
+
+(defun hierarchy-parent (hierarchy item)
+ "In HIERARCHY, return parent of ITEM."
+ (map-elt (hierarchy--parents hierarchy) item))
+
+(defun hierarchy-children (hierarchy parent)
+ "In HIERARCHY, return children of PARENT."
+ (map-elt (hierarchy--children hierarchy) parent (list)))
+
+(defun hierarchy-child-p (hierarchy item1 item2)
+ "In HIERARCHY, return non-nil if and only if ITEM1 is a child of ITEM2."
+ (equal (hierarchy-parent hierarchy item1) item2))
+
+(defun hierarchy-descendant-p (hierarchy item1 item2)
+ "In HIERARCHY, return non-nil if and only if ITEM1 is a descendant of ITEM2.
+
+ITEM1 is a descendant of ITEM2 if and only if both are items of HIERARCHY
+and either:
+
+- ITEM1 is child of ITEM2, or
+- ITEM1's parent is a descendant of ITEM2."
+ (and
+ (hierarchy-has-item hierarchy item1)
+ (hierarchy-has-item hierarchy item2)
+ (or
+ (hierarchy-child-p hierarchy item1 item2)
+ (hierarchy-descendant-p
+ hierarchy (hierarchy-parent hierarchy item1) item2))))
+
+(defun hierarchy-equal (hierarchy1 hierarchy2)
+ "Return t if HIERARCHY1 and HIERARCHY2 are equal.
+
+Two equal hierarchies share the same items and the same
+relationships among them."
+ (and (hierarchy-p hierarchy1)
+ (hierarchy-p hierarchy2)
+ (= (hierarchy-length hierarchy1) (hierarchy-length hierarchy2))
+ ;; parents are the same
+ (seq-every-p (lambda (child)
+ (equal (hierarchy-parent hierarchy1 child)
+ (hierarchy-parent hierarchy2 child)))
+ (map-keys (hierarchy--parents hierarchy1)))
+ ;; children are the same
+ (seq-every-p (lambda (parent)
+ (hierarchy--set-equal
+ (hierarchy-children hierarchy1 parent)
+ (hierarchy-children hierarchy2 parent)
+ :test #'equal))
+ (map-keys (hierarchy--children hierarchy1)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Navigation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-map-item (func item hierarchy &optional indent)
+ "Return the result of applying FUNC to ITEM and its descendants in HIERARCHY.
+
+This function navigates the tree top-down: FUNCTION is first called on item
+and then on each of its children. Results are concatenated in a list.
+
+INDENT is a number (default 0) representing the indentation of ITEM in
+HIERARCHY. FUNC should take 2 argument: the item and its indentation
+level."
+ (let ((indent (or indent 0)))
+ (cons
+ (funcall func item indent)
+ (seq-mapcat (lambda (child) (hierarchy-map-item func child
+ hierarchy (1+ indent)))
+ (hierarchy-children hierarchy item)))))
+
+(defun hierarchy-map (func hierarchy &optional indent)
+ "Return the result of applying FUNC to each element of HIERARCHY.
+
+This function navigates the tree top-down: FUNCTION is first called on each
+root. To do so, it calls `hierarchy-map-item' on each root
+sequentially. Results are concatenated in a list.
+
+FUNC should take 2 arguments: the item and its indentation level.
+
+INDENT is a number (default 0) representing the indentation of HIERARCHY's
+roots."
+ (let ((indent (or indent 0)))
+ (seq-mapcat (lambda (root) (hierarchy-map-item func root hierarchy indent))
+ (hierarchy-roots hierarchy))))
+
+(defun hierarchy-map-tree (function hierarchy &optional item indent)
+ "Apply FUNCTION on each item of HIERARCHY under ITEM.
+
+This function navigates the tree bottom-up: FUNCTION is first called on
+leafs and the result is passed as parameter when calling FUNCTION on
+parents.
+
+FUNCTION should take 3 parameters: the current item, its indentation
+level (a number), and a list representing the result of applying
+`hierarchy-map-tree' to each child of the item.
+
+INDENT is 0 by default and is passed as second parameter to FUNCTION.
+INDENT is incremented by 1 at each level of the tree.
+
+This function returns the result of applying FUNCTION to ITEM (the first
+root if nil)."
+ (let ((item (or item (car (hierarchy-roots hierarchy))))
+ (indent (or indent 0)))
+ (funcall function item indent
+ (mapcar (lambda (child)
+ (hierarchy-map-tree function hierarchy
+ child (1+ indent)))
+ (hierarchy-children hierarchy item)))))
+
+(defun hierarchy-map-hierarchy (function hierarchy)
+ "Apply FUNCTION to each item of HIERARCHY in a new hierarchy.
+
+FUNCTION should take 2 parameters, the current item and its
+indentation level (a number), and should return an item to be
+added to the new hierarchy."
+ (let* ((items (make-hash-table :test #'equal))
+ (transform (lambda (item) (map-elt items item))))
+ ;; Make 'items', a table mapping original items to their
+ ;; transformation
+ (hierarchy-map (lambda (item indent)
+ (map-put! items item (funcall function item indent)))
+ hierarchy)
+ (hierarchy--make
+ :roots (mapcar transform (hierarchy-roots hierarchy))
+ :parents (let ((result (make-hash-table :test #'equal)))
+ (map-apply (lambda (child parent)
+ (map-put! result
+ (funcall transform child)
+ (funcall transform parent)))
+ (hierarchy--parents hierarchy))
+ result)
+ :children (let ((result (make-hash-table :test #'equal)))
+ (map-apply (lambda (parent children)
+ (map-put! result
+ (funcall transform parent)
+ (seq-map transform children)))
+ (hierarchy--children hierarchy))
+ result)
+ :seen-items (let ((result (make-hash-table :test #'equal)))
+ (map-apply (lambda (item v)
+ (map-put! result
+ (funcall transform item)
+ v))
+ (hierarchy--seen-items hierarchy))
+ result))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Display
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-labelfn-indent (labelfn &optional indent-string)
+ "Return a function rendering LABELFN indented with INDENT-STRING.
+
+INDENT-STRING defaults to a 2-space string. Indentation is
+multiplied by the depth of the displayed item."
+ (let ((indent-string (or indent-string " ")))
+ (lambda (item indent)
+ (dotimes (_ indent) (insert indent-string))
+ (funcall labelfn item indent))))
+
+(defun hierarchy-labelfn-button (labelfn actionfn)
+ "Return a function rendering LABELFN in a button.
+
+Clicking the button triggers ACTIONFN. ACTIONFN is a function
+taking an item of HIERARCHY and an indentation value (a number)
+as input. This function is called when an item is clicked. The
+return value of ACTIONFN is ignored."
+ (lambda (item indent)
+ (let ((start (point)))
+ (funcall labelfn item indent)
+ (make-text-button start (point)
+ 'action (lambda (_) (funcall actionfn item indent))))))
+
+(defun hierarchy-labelfn-button-if (labelfn buttonp actionfn)
+ "Return a function rendering LABELFN as a button if BUTTONP.
+
+Pass LABELFN and ACTIONFN to `hierarchy-labelfn-button' if
+BUTTONP is non-nil. Otherwise, render LABELFN without making it
+a button.
+
+BUTTONP is a function taking an item of HIERARCHY and an
+indentation value (a number) as input."
+ (lambda (item indent)
+ (if (funcall buttonp item indent)
+ (funcall (hierarchy-labelfn-button labelfn actionfn) item indent)
+ (funcall labelfn item indent))))
+
+(defun hierarchy-labelfn-to-string (labelfn item indent)
+ "Execute LABELFN on ITEM and INDENT. Return result as a string."
+ (with-temp-buffer
+ (funcall labelfn item indent)
+ (buffer-substring (point-min) (point-max))))
+
+(defun hierarchy-print (hierarchy &optional to-string)
+ "Insert HIERARCHY in current buffer as plain text.
+
+Use TO-STRING to convert each element to a string. TO-STRING is
+a function taking an item of HIERARCHY as input and returning a
+string. If nil, TO-STRING defaults to a call to `format' with \"%s\"."
+ (let ((to-string (or to-string (lambda (item) (format "%s" item)))))
+ (hierarchy-map
+ (hierarchy-labelfn-indent (lambda (item _)
+ (insert (funcall to-string item) "\n")))
+ hierarchy)))
+
+(defun hierarchy-to-string (hierarchy &optional to-string)
+ "Return a string representing HIERARCHY.
+
+TO-STRING is passed unchanged to `hierarchy-print'."
+ (with-temp-buffer
+ (hierarchy-print hierarchy to-string)
+ (buffer-substring (point-min) (point-max))))
+
+(defun hierarchy-tabulated-imenu-action (_item-name position)
+ "Move to ITEM-NAME at POSITION in current buffer."
+ (goto-char position)
+ (back-to-indentation))
+
+(define-derived-mode hierarchy-tabulated-mode tabulated-list-mode "Hierarchy
tabulated"
+ "Major mode to display a hierarchy as a tabulated list."
+ (setq-local imenu-generic-expression
+ ;; debbugs: 26457 - Cannot pass a function to
+ ;; imenu-generic-expression. Add
+ ;; `hierarchy-tabulated-imenu-action' to the end of the
+ ;; list when bug is fixed
+ '(("Item" "^[[:space:]]+\\(?1:.+\\)$" 1))))
+
+(defun hierarchy-tabulated-display (hierarchy labelfn &optional buffer)
+ "Display HIERARCHY as a tabulated list in `hierarchy-tabulated-mode'.
+
+LABELFN is a function taking an item of HIERARCHY and an indentation
+level (a number) as input and inserting a string to be displayed in the
+table.
+
+The tabulated list is displayed in BUFFER, or a newly created buffer if
+nil. The buffer is returned."
+ (let ((buffer (or buffer (generate-new-buffer "hierarchy-tabulated"))))
+ (with-current-buffer buffer
+ (hierarchy-tabulated-mode)
+ (setq tabulated-list-format
+ (vector '("Item name" 0 nil)))
+ (setq tabulated-list-entries
+ (hierarchy-map (lambda (item indent)
+ (list item (vector (hierarchy-labelfn-to-string
+ labelfn item indent))))
+ hierarchy))
+ (tabulated-list-init-header)
+ (tabulated-list-print))
+ buffer))
+
+(declare-function widget-convert "wid-edit")
+(defun hierarchy-convert-to-tree-widget (hierarchy labelfn)
+ "Return a tree-widget for HIERARCHY.
+
+LABELFN is a function taking an item of HIERARCHY and an indentation
+value (a number) as parameter and inserting a string to be displayed as a
+node label."
+ (require 'wid-edit)
+ (require 'tree-widget)
+ (hierarchy-map-tree (lambda (item indent children)
+ (widget-convert
+ 'tree-widget
+ :tag (hierarchy-labelfn-to-string labelfn item indent)
+ :args children))
+ hierarchy))
+
+(defun hierarchy-tree-display (hierarchy labelfn &optional buffer)
+ "Display HIERARCHY as a tree widget in a new buffer.
+
+HIERARCHY and LABELFN are passed unchanged to
+`hierarchy-convert-to-tree-widget'.
+
+The tree widget is displayed in BUFFER, or a newly created buffer if
+nil. The buffer is returned."
+ (let ((buffer (or buffer (generate-new-buffer "*hierarchy-tree*")))
+ (tree-widget (hierarchy-convert-to-tree-widget hierarchy labelfn)))
+ (with-current-buffer buffer
+ (setq-local buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (widget-create tree-widget)
+ (goto-char (point-min))
+ (special-mode)))
+ buffer))
+
+(provide 'hierarchy)
+
+;;; hierarchy.el ends here
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 4c1a179..1cc68e1 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -492,6 +492,7 @@ keys. Keys are compared using `equal'."
SEQUENCE must be a sequence of numbers or markers."
(apply #'min (seq-into sequence 'list)))
+;;;###autoload
(cl-defgeneric seq-max (sequence)
"Return the largest element of SEQUENCE.
SEQUENCE must be a sequence of numbers or markers."
diff --git a/lisp/epa-file.el b/lisp/epa-file.el
index 20043a9..bbd9279 100644
--- a/lisp/epa-file.el
+++ b/lisp/epa-file.el
@@ -151,17 +151,25 @@ encryption is used."
(nth 3 error)))
(let ((exists (file-exists-p local-file)))
(when exists
- ;; Hack to prevent find-file from opening empty buffer
- ;; when decryption failed (bug#6568). See the place
- ;; where `find-file-not-found-functions' are called in
- ;; `find-file-noselect-1'.
- (setq-local epa-file-error error)
- (add-hook 'find-file-not-found-functions
- 'epa-file--find-file-not-found-function
- nil t)
- (epa-display-error context))
- (signal (if exists 'file-error 'file-missing)
- (cons "Opening input file" (cdr error))))))
+ (epa-display-error context)
+ ;; When the .gpg file isn't an encrypted file (e.g.,
+ ;; it's a keyring.gpg file instead), then gpg will
+ ;; say "Unexpected exit" as the error message. In
+ ;; that case, just display the bytes.
+ (if (equal (caddr error) "Unexpected; Exit")
+ (setq string (with-temp-buffer
+ (insert-file-contents-literally local-file)
+ (buffer-string)))
+ ;; Hack to prevent find-file from opening empty buffer
+ ;; when decryption failed (bug#6568). See the place
+ ;; where `find-file-not-found-functions' are called in
+ ;; `find-file-noselect-1'.
+ (setq-local epa-file-error error)
+ (add-hook 'find-file-not-found-functions
+ 'epa-file--find-file-not-found-function
+ nil t)
+ (signal (if exists 'file-error 'file-missing)
+ (cons "Opening input file" (cdr error))))))))
(set-buffer buf) ;In case timer/filter changed/killed it (bug#16029)!
(setq-local epa-file-encrypt-to
(mapcar #'car (epg-context-result-for
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el
index fc45725..4afe6a7 100644
--- a/lisp/erc/erc-capab.el
+++ b/lisp/erc/erc-capab.el
@@ -170,11 +170,11 @@ PARSED is an `erc-parsed' response struct."
(string-match "^\\([-\\+]\\)\\(.+\\)$" msg))
(setf (erc-response.contents parsed)
(if erc-capab-identify-mode
- (erc-propertize (match-string 2 msg)
- 'erc-identified
- (if (string= (match-string 1 msg) "+")
- 1
- 0))
+ (propertize (match-string 2 msg)
+ 'erc-identified
+ (if (string= (match-string 1 msg) "+")
+ 1
+ 0))
(match-string 2 msg)))
nil)))
@@ -190,9 +190,9 @@ PARSED is an `erc-parsed' response struct."
;; assuming the first use of `nickname' is the sender's nick
(re-search-forward (regexp-quote nickname) nil t))
(goto-char (match-beginning 0))
- (insert (erc-propertize erc-capab-identify-prefix
- 'font-lock-face
- 'erc-capab-identify-unidentified))))))
+ (insert (propertize erc-capab-identify-prefix
+ 'font-lock-face
+ 'erc-capab-identify-unidentified))))))
(defun erc-capab-identify-get-unidentified-nickname (parsed)
"Return the nickname of the user if unidentified.
diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el
index 388728b..d71221b 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/erc/erc-compat.el
@@ -43,12 +43,12 @@ Return the same string, if the encoding operation is
trivial.
See `erc-encoding-coding-alist'."
(encode-coding-string s coding-system t))
-(defalias 'erc-propertize 'propertize)
-(defalias 'erc-view-mode-enter 'view-mode-enter)
+(define-obsolete-function-alias 'erc-propertize #'propertize "28.1")
+(define-obsolete-function-alias 'erc-view-mode-enter #'view-mode-enter "28.1")
(autoload 'help-function-arglist "help-fns")
-(defalias 'erc-function-arglist 'help-function-arglist)
-(defalias 'erc-delete-dups 'delete-dups)
-(defalias 'erc-replace-regexp-in-string 'replace-regexp-in-string)
+(define-obsolete-function-alias 'erc-function-arglist #'help-function-arglist
"28.1")
+(define-obsolete-function-alias 'erc-delete-dups #'delete-dups "28.1")
+(define-obsolete-function-alias 'erc-replace-regexp-in-string
#'replace-regexp-in-string "28.1")
(defun erc-set-write-file-functions (new-val)
(set (make-local-variable 'write-file-functions) new-val))
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index 8ccceec..bf98eb8 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -423,7 +423,7 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
#'(lambda (elt)
(eq (plist-get elt :type) 'CHAT))
erc-dcc-list)))
- ('close (erc-delete-dups
+ ('close (delete-dups
(mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
erc-dcc-list)))
('get (mapcar #'erc-dcc-nick
@@ -636,8 +636,8 @@ that subcommand."
(define-inline erc-dcc-unquote-filename (filename)
(inline-quote
- (erc-replace-regexp-in-string "\\\\\\\\" "\\"
- (erc-replace-regexp-in-string "\\\\\"" "\""
,filename t t) t t)))
+ (replace-regexp-in-string "\\\\\\\\" "\\"
+ (replace-regexp-in-string "\\\\\"" "\"" ,filename
t t) t t)))
(defun erc-dcc-handle-ctcp-send (proc query nick login host to)
"This is called if a CTCP DCC SEND subcommand is sent to the client.
@@ -1193,8 +1193,8 @@ other client."
(setq posn (match-end 0))
(erc-display-message
nil nil proc
- 'dcc-chat-privmsg ?n (erc-propertize erc-dcc-from 'font-lock-face
- 'erc-nick-default-face) ?m line))
+ 'dcc-chat-privmsg ?n (propertize erc-dcc-from 'font-lock-face
+ 'erc-nick-default-face) ?m line))
(setq erc-dcc-unprocessed-output (substring str posn)))))
(defun erc-dcc-chat-buffer-killed ()
diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el
index 5faeabb..036d773 100644
--- a/lisp/erc/erc-list.el
+++ b/lisp/erc/erc-list.el
@@ -71,13 +71,13 @@
(defun erc-list-make-string (channel users topic)
(concat
channel
- (erc-propertize " "
- 'display (list 'space :align-to erc-list-nusers-column)
- 'face 'fixed-pitch)
+ (propertize " "
+ 'display (list 'space :align-to erc-list-nusers-column)
+ 'face 'fixed-pitch)
users
- (erc-propertize " "
- 'display (list 'space :align-to erc-list-topic-column)
- 'face 'fixed-pitch)
+ (propertize " "
+ 'display (list 'space :align-to erc-list-topic-column)
+ 'face 'fixed-pitch)
topic))
;; Insert a record into the list buffer.
@@ -143,19 +143,19 @@
;; Helper function that makes a buttonized column header.
(defun erc-list-button (title column)
- (erc-propertize title
- 'column-number column
- 'help-echo "mouse-1: sort by column"
- 'mouse-face 'header-line-highlight
- 'keymap erc-list-menu-sort-button-map))
+ (propertize title
+ 'column-number column
+ 'help-echo "mouse-1: sort by column"
+ 'mouse-face 'header-line-highlight
+ 'keymap erc-list-menu-sort-button-map))
(define-derived-mode erc-list-menu-mode special-mode "ERC-List"
"Major mode for editing a list of irc channels."
(setq header-line-format
(concat
- (erc-propertize " "
- 'display '(space :align-to 0)
- 'face 'fixed-pitch)
+ (propertize " "
+ 'display '(space :align-to 0)
+ 'face 'fixed-pitch)
(erc-list-make-string (erc-list-button "Channel" 1)
(erc-list-button "# Users" 2)
"Topic")))
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index 1bad6d1..e2c066d 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -334,7 +334,7 @@ This will not work with full paths, only names.
Any unsafe characters in the name are replaced with \"!\". The
filename is downcased."
- (downcase (erc-replace-regexp-in-string
+ (downcase (replace-regexp-in-string
"[/\\]" "!" (convert-standard-filename filename))))
(defun erc-current-logfile (&optional buffer)
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index 0e98f2b..6e87a18 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -577,9 +577,9 @@ See `erc-log-match-format'."
(with-current-buffer buffer
(unless buffer-already
(insert " == Type \"q\" to dismiss messages ==\n")
- (erc-view-mode-enter nil (lambda (buffer)
- (when (y-or-n-p "Discard messages? ")
- (kill-buffer buffer)))))
+ (view-mode-enter nil (lambda (buffer)
+ (when (y-or-n-p "Discard messages? ")
+ (kill-buffer buffer)))))
buffer)))
(defun erc-log-matches-come-back (proc parsed)
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el
index 415fb53..8551cdd 100644
--- a/lisp/erc/erc-networks.el
+++ b/lisp/erc/erc-networks.el
@@ -812,7 +812,7 @@ As an example:
(let* ((completion-ignore-case t)
(net (intern
(completing-read "Network: "
- (erc-delete-dups
+ (delete-dups
(mapcar (lambda (x)
(list (symbol-name (nth 1 x))))
erc-server-alist)))))
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 8830dd4..404a4c0 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -63,6 +63,8 @@
(require 'thingatpt)
(require 'auth-source)
(require 'erc-compat)
+(require 'time-date)
+(require 'iso8601)
(eval-when-compile (require 'subr-x))
(defvar erc-official-location
@@ -1628,9 +1630,10 @@ symbol, it may have these values:
(and (erc-server-buffer-p)
(not (erc-server-process-alive)))))
;; Channel buffer; check that it's from the right server.
- (with-current-buffer (get-buffer candidate)
- (and (string= erc-session-server server)
- (erc-port-equal erc-session-port port)))))
+ (and target
+ (with-current-buffer (get-buffer candidate)
+ (and (string= erc-session-server server)
+ (erc-port-equal erc-session-port port))))))
(setq buffer-name candidate)))
;; if buffer-name is unset, neither candidate worked out for us,
;; fallback to the old <N> uniquification method:
@@ -1860,7 +1863,7 @@ buffer rather than a server buffer.")
;; modify `transforms' to specify what needs to be changed
;; each item is in the format '(old . new)
(let ((transforms '((pcomplete . completion))))
- (erc-delete-dups
+ (delete-dups
(mapcar (lambda (m) (or (cdr (assoc m transforms)) m))
mods))))
@@ -2313,7 +2316,7 @@ and appears in face `erc-input-face' in the buffer."
(setq result (concat result network-name
" << " line "\n")))
result)
- (erc-propertize
+ (propertize
(concat network-name " >> " string
(if (/= ?\n
(aref string
@@ -2336,7 +2339,7 @@ If ARG is non-nil, show the *erc-protocol* buffer."
(interactive "P")
(let* ((buf (get-buffer-create "*erc-protocol*")))
(with-current-buffer buf
- (erc-view-mode-enter)
+ (view-mode-enter)
(when (null (current-local-map))
(let ((inhibit-read-only t))
(insert (erc-make-notice "This buffer displays all IRC protocol
traffic exchanged with each server.\n"))
@@ -2770,7 +2773,7 @@ See also `erc-server-send'."
(defun erc-get-arglist (fun)
"Return the argument list of a function without the parens."
- (let ((arglist (format "%S" (erc-function-arglist fun))))
+ (let ((arglist (format "%S" (help-function-arglist fun))))
(if (string-match "\\`(\\(.*\\))\\'" arglist)
(match-string 1 arglist)
arglist)))
@@ -2905,6 +2908,44 @@ therefore has to contain the command itself as well."
(erc-server-send (substring line 1))
t)
+(defvar erc--read-time-period-history nil)
+
+(defun erc--read-time-period (prompt)
+ "Read a time period on the \"2h\" format.
+If there's no letter spec, the input is interpreted as a number of seconds.
+
+If input is blank, this function returns nil. Otherwise it
+returns the time spec converted to a number of seconds."
+ (let ((period (string-trim
+ (read-string prompt nil 'erc--read-time-period-history))))
+ (cond
+ ;; Blank input.
+ ((zerop (length period))
+ nil)
+ ;; All-number -- interpret as seconds.
+ ((string-match-p "\\`[0-9]+\\'" period)
+ (string-to-number period))
+ ;; Parse as a time spec.
+ (t
+ (let ((time (condition-case nil
+ (iso8601-parse-duration
+ (concat (cond
+ ((string-match-p "\\`P" (upcase period))
+ ;; Somebody typed in a full ISO8601 period.
+ (upcase period))
+ ((string-match-p "[YD]" (upcase period))
+ ;; If we have a year/day element,
+ ;; we have a full spec.
+ "P")
+ (t
+ ;; Otherwise it's just a sub-day spec.
+ "PT"))
+ (upcase period)))
+ (wrong-type-argument nil))))
+ (unless time
+ (user-error "%s is not a valid time period" period))
+ (decoded-time-period time))))))
+
(defun erc-cmd-IGNORE (&optional user)
"Ignore USER. This should be a regexp matching nick!user@host.
If no USER argument is specified, list the contents of `erc-ignore-list'."
@@ -2914,10 +2955,18 @@ If no USER argument is specified, list the contents of
`erc-ignore-list'."
(y-or-n-p (format "Use regexp-quoted form (%s) instead? "
quoted)))
(setq user quoted))
- (erc-display-line
- (erc-make-notice (format "Now ignoring %s" user))
- 'active)
- (erc-with-server-buffer (add-to-list 'erc-ignore-list user)))
+ (let ((timeout
+ (erc--read-time-period
+ "Add a timeout? (Blank for no, or a time spec like 2h): "))
+ (buffer (current-buffer)))
+ (when timeout
+ (run-at-time timeout nil
+ (lambda ()
+ (erc--unignore-user user buffer))))
+ (erc-display-line
+ (erc-make-notice (format "Now ignoring %s" user))
+ 'active)
+ (erc-with-server-buffer (add-to-list 'erc-ignore-list user))))
(if (null (erc-with-server-buffer erc-ignore-list))
(erc-display-line (erc-make-notice "Ignore list is empty") 'active)
(erc-display-line (erc-make-notice "Ignore list:") 'active)
@@ -2941,12 +2990,17 @@ If no USER argument is specified, list the contents of
`erc-ignore-list'."
(erc-make-notice (format "%s is not currently ignored!" user))
'active)))
(when ignored-nick
+ (erc--unignore-user user (current-buffer))))
+ t)
+
+(defun erc--unignore-user (user buffer)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
(erc-display-line
(erc-make-notice (format "No longer ignoring %s" user))
'active)
(erc-with-server-buffer
- (setq erc-ignore-list (delete ignored-nick erc-ignore-list)))))
- t)
+ (setq erc-ignore-list (delete user erc-ignore-list))))))
(defun erc-cmd-CLEAR ()
"Clear the window content."
@@ -3504,7 +3558,7 @@ If S is non-nil, it will be used as the quit reason."
If S is non-nil, it will be used as the quit reason."
(or s
(if (fboundp 'yow)
- (erc-replace-regexp-in-string "\n" "" (yow))
+ (replace-regexp-in-string "\n" "" (yow))
(erc-quit/part-reason-default))))
(make-obsolete 'erc-quit-reason-zippy "it will be removed." "24.4")
@@ -3531,7 +3585,7 @@ If S is non-nil, it will be used as the part reason."
If S is non-nil, it will be used as the quit reason."
(or s
(if (fboundp 'yow)
- (erc-replace-regexp-in-string "\n" "" (yow))
+ (replace-regexp-in-string "\n" "" (yow))
(erc-quit/part-reason-default))))
(make-obsolete 'erc-part-reason-zippy "it will be removed." "24.4")
@@ -3947,13 +4001,13 @@ If FACE is non-nil, it will be used to propertize the
prompt. If it is nil,
;; Do not extend the text properties when typing at the end
;; of the prompt, but stuff typed in front of the prompt
;; shall remain part of the prompt.
- (setq prompt (erc-propertize prompt
- 'start-open t ; XEmacs
- 'rear-nonsticky t ; Emacs
- 'erc-prompt t
- 'field t
- 'front-sticky t
- 'read-only t))
+ (setq prompt (propertize prompt
+ 'start-open t ; XEmacs
+ 'rear-nonsticky t ; Emacs
+ 'erc-prompt t
+ 'field t
+ 'front-sticky t
+ 'read-only t))
(erc-put-text-property 0 (1- (length prompt))
'font-lock-face (or face 'erc-prompt-face)
prompt)
@@ -4336,15 +4390,15 @@ See also `erc-format-nick-function'."
(defun erc-get-user-mode-prefix (user)
(when user
(cond ((erc-channel-user-owner-p user)
- (erc-propertize "~" 'help-echo "owner"))
+ (propertize "~" 'help-echo "owner"))
((erc-channel-user-admin-p user)
- (erc-propertize "&" 'help-echo "admin"))
+ (propertize "&" 'help-echo "admin"))
((erc-channel-user-op-p user)
- (erc-propertize "@" 'help-echo "operator"))
+ (propertize "@" 'help-echo "operator"))
((erc-channel-user-halfop-p user)
- (erc-propertize "%" 'help-echo "half-op"))
+ (propertize "%" 'help-echo "half-op"))
((erc-channel-user-voice-p user)
- (erc-propertize "+" 'help-echo "voice"))
+ (propertize "+" 'help-echo "voice"))
(t ""))))
(defun erc-format-@nick (&optional user _channel-data)
@@ -4355,7 +4409,7 @@ prefix. Use CHANNEL-DATA to determine op and voice
status. See
also `erc-format-nick-function'."
(when user
(let ((nick (erc-server-user-nickname user)))
- (concat (erc-propertize
+ (concat (propertize
(erc-get-user-mode-prefix nick)
'font-lock-face 'erc-nick-prefix-face)
nick))))
@@ -4368,12 +4422,12 @@ also `erc-format-nick-function'."
(nick (erc-current-nick))
(mode (erc-get-user-mode-prefix nick)))
(concat
- (erc-propertize open 'font-lock-face 'erc-default-face)
- (erc-propertize mode 'font-lock-face 'erc-my-nick-prefix-face)
- (erc-propertize nick 'font-lock-face 'erc-my-nick-face)
- (erc-propertize close 'font-lock-face 'erc-default-face)))
+ (propertize open 'font-lock-face 'erc-default-face)
+ (propertize mode 'font-lock-face 'erc-my-nick-prefix-face)
+ (propertize nick 'font-lock-face 'erc-my-nick-face)
+ (propertize close 'font-lock-face 'erc-default-face)))
(let ((prefix "> "))
- (erc-propertize prefix 'font-lock-face 'erc-default-face))))
+ (propertize prefix 'font-lock-face 'erc-default-face))))
(defun erc-echo-notice-in-default-buffer (s parsed buffer _sender)
"Echos a private notice in the default buffer, namely the
@@ -6435,16 +6489,16 @@ if `erc-away' is non-nil."
(fill-region (point-min) (point-max))
(buffer-string))))
(setq header-line-format
- (erc-replace-regexp-in-string
+ (replace-regexp-in-string
"%"
"%%"
(if face
- (erc-propertize header 'help-echo help-echo
- 'face face)
- (erc-propertize header 'help-echo help-echo))))))
+ (propertize header 'help-echo help-echo
+ 'face face)
+ (propertize header 'help-echo help-echo))))))
(t (setq header-line-format
(if face
- (erc-propertize header 'face face)
+ (propertize header 'face face)
header)))))))
(force-mode-line-update)))
@@ -6711,7 +6765,7 @@ functions."
nick user host channel
(if (not (string= reason ""))
(format ": %s"
- (erc-replace-regexp-in-string "%" "%%" reason))
+ (replace-regexp-in-string "%" "%%" reason))
"")))))
diff --git a/lisp/files.el b/lisp/files.el
index 742fd78..1909669 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -2683,8 +2683,6 @@ since only a single case-insensitive search through the
alist is made."
("\\.p\\'" . pascal-mode)
("\\.pas\\'" . pascal-mode)
("\\.\\(dpr\\|DPR\\)\\'" . delphi-mode)
- ("\\.ad[abs]\\'" . ada-mode)
- ("\\.ad[bs]\\.dg\\'" . ada-mode)
("\\.\\([pP]\\([Llm]\\|erl\\|od\\)\\|al\\)\\'" . perl-mode)
("Imakefile\\'" . makefile-imake-mode)
("Makeppfile\\(?:\\.mk\\)?\\'" . makefile-makepp-mode) ; Put this before
.mk
diff --git a/lisp/finder.el b/lisp/finder.el
index f04d73e..820d6d0 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -197,7 +197,7 @@ from; the default is `load-path'."
(cons d f))
(directory-files d nil el-file-regexp))))
(progress (make-progress-reporter
- (byte-compile-info-string "Scanning files for finder")
+ (byte-compile-info "Scanning files for finder")
0 (length files)))
package-override base-name ; processed
summary keywords package version entry desc)
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index cd24f49..48ac123 100644
--- a/lisp/generic-x.el
+++ b/lisp/generic-x.el
@@ -643,7 +643,7 @@ like an INI file. You can add this hook to
`find-file-hook'."
("\\([^ =\n\r]+\\)=\\([^ \n\r]*\\)"
(1 font-lock-variable-name-face)
(2 font-lock-keyword-face)))
- '("inventory")
+ '("inventory\\'")
(list
(function
(lambda ()
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index cb20d71..e0339cc 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -5849,7 +5849,10 @@ all parts."
(concat "; " gnus-tmp-name))))
(unless (equal gnus-tmp-description "")
(setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
- (when (zerop gnus-tmp-length)
+ (when (and (zerop gnus-tmp-length)
+ ;; Only nnimap supports partial fetches so far.
+ nnimap-fetch-partial-articles
+ (string-match "^nnimap\\+" gnus-newsgroup-name))
(setq gnus-tmp-type-long
(concat
gnus-tmp-type-long
@@ -6018,6 +6021,7 @@ If nil, don't show those extra buttons."
(defun gnus-mime-display-single (handle)
(let ((type (mm-handle-media-type handle))
(ignored gnus-ignored-mime-types)
+ (mm-inline-font-lock (gnus-visual-p 'article-highlight 'highlight))
(not-attachment t)
display text)
(catch 'ignored
@@ -8340,6 +8344,7 @@ url is put as the `gnus-button-url' overlay property on
the button."
(and (match-end 6) (list (string-to-number (match-string 6
address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
+ (declare (obsolete message-parse-mailto-url "28.1"))
(let (retval pairs cur key val)
(setq pairs (split-string query "&"))
(while pairs
@@ -8359,31 +8364,8 @@ url is put as the `gnus-button-url' overlay property on
the button."
(defun gnus-url-mailto (url)
;; Send mail to someone
- (setq url (replace-regexp-in-string "\n" " " url))
- (when (string-match "mailto:/*\\(.*\\)" url)
- (setq url (substring url (match-beginning 1) nil)))
- (let* ((args (gnus-url-parse-query-string
- (if (string-match "^\\?" url)
- (substring url 1)
- (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
- (concat "to=" (match-string 1 url) "&"
- (match-string 2 url))
- (concat "to=" url)))))
- (subject (cdr-safe (assoc "subject" args)))
- func)
- (gnus-msg-mail)
- (while args
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
- (if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
- (insert (replace-regexp-in-string
- "\r\n" "\n"
- (mapconcat #'identity (reverse (cdar args)) ", ") nil t))
- (setq args (cdr args)))
- (if subject
- (message-goto-body)
- (message-goto-subject))))
+ (gnus-msg-mail)
+ (message-mailto-1 url))
(defun gnus-button-embedded-url (address)
"Activate ADDRESS with `browse-url'."
diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el
index 305e17f..29d3e30 100644
--- a/lisp/gnus/gnus-icalendar.el
+++ b/lisp/gnus/gnus-icalendar.el
@@ -312,7 +312,8 @@ status will be retrieved from the first matching attendee
record."
(unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
reply-event-lines)
- (error "Could not find an event attendee matching given identity"))
+ (lwarn 'gnus-icalendar :warning
+ "Could not find an event attendee matching given identity"))
(mapconcat #'identity `("BEGIN:VEVENT"
,@(nreverse reply-event-lines)
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 719498a..4363860 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -12284,7 +12284,7 @@ no matter what the properties `:decode' and `:headers'
are."
(interactive (gnus-interactive "P\ny"))
(require 'gnus-art)
(let* ((articles (gnus-summary-work-articles n))
- (result-buffer "*Shell Command Output*")
+ (result-buffer shell-command-buffer-name)
(all-headers (not (memq sym '(nil r))))
(gnus-save-all-headers (or all-headers gnus-save-all-headers))
(raw (eq sym 'r))
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index 8d8956f..abe546b 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -1654,6 +1654,7 @@ The first found will be returned if a file has hard or
symbolic links."
"To each element of LIST apply PREDICATE.
Return nil if LIST is no list or is empty or some test returns nil;
otherwise, return t."
+ (declare (obsolete nil "28.1"))
(when (and list (listp list))
(let ((result (mapcar predicate list)))
(not (memq nil result)))))
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 36b2835..baa3146 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -142,7 +142,7 @@ used to display Gnus windows."
(pipe
(vertical 1.0
(summary 0.25 point)
- ("*Shell Command Output*" 1.0)))
+ (shell-command-buffer-name 1.0)))
(bug
(vertical 1.0
(if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index fb560f0..ab625be 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -303,6 +303,13 @@ any confusion."
:link '(custom-manual "(message)Message Headers")
:type 'regexp)
+(defcustom message-screenshot-command '("import" "png:-")
+ "Command to take a screenshot.
+The command should insert a PNG in the current buffer."
+ :group 'message-various
+ :type '(list string)
+ :version "28.1")
+
;;; Start of variables adopted from `message-utils.el'.
(defcustom message-subject-trailing-was-query t
@@ -2730,6 +2737,64 @@ systematically send encrypted emails when possible."
(when (message-all-epg-keys-available-p)
(mml-secure-message-sign-encrypt)))
+(defcustom message-openpgp-header nil
+ "Specification for the \"OpenPGP\" header of outgoing messages.
+
+The value must be a list of three elements, all strings:
+- Key ID, in hexadecimal form;
+- Key URL or ASCII armoured key; and
+- Protection preference, one of: \"unprotected\", \"sign\",
+ \"encrypt\" or \"signencrypt\".
+
+Each of the elements may be nil, in which case its part in the
+OpenPGP header will be left out. If all the values are nil,
+or `message-openpgp-header' is itself nil, the OpenPGP header
+will not be inserted."
+ :type '(choice
+ (const nil :tag "Don't add OpenPGP header")
+ (list (choice (string :tag "ID")
+ (const nil :tag "No ID"))
+ (choice (string :tag "Key")
+ (const nil :tag "No Key"))
+ (choice (other nil :tag "None")
+ (const "unprotected" :tag "Unprotected")
+ (const "sign" :tag "Sign")
+ (const "encrypt" :tag "Encrypt")
+ (const "signencrypt" :tag "Sign and Encrypt"))))
+ :version "28.1")
+
+(defun message-add-openpgp-header ()
+ "Add OpenPGP header to point to public key.
+
+Header will be constructed as specified in `message-openpgp-header'.
+
+Consider adding this function to `message-send-hook'."
+ ;; See https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header
+ (when (and message-openpgp-header
+ (or (nth 0 message-openpgp-header)
+ (nth 1 message-openpgp-header)
+ (nth 2 message-openpgp-header)))
+ (with-temp-buffer
+ (insert "OpenPGP: ")
+ ;; add ID
+ (let (need-sep)
+ (when (nth 0 message-openpgp-header)
+ (insert "id=" (nth 0 message-openpgp-header))
+ (setq need-sep t))
+ ;; add URL
+ (when (nth 1 message-openpgp-header)
+ (when need-sep (insert "; "))
+ (if (string-match-p ";")
+ (insert "url=\"" (nth 1 message-openpgp-header) "\"")
+ (insert "url=\"" (nth 1 message-openpgp-header) "\""))
+ (setq need-sep t))
+ ;; add preference
+ (when (nth 2 message-openpgp-header)
+ (when need-sep (insert "; "))
+ (insert "preference=" (nth 2 message-openpgp-header))))
+ ;; insert header
+ (message-add-header (buffer-string)))))
+
;;;
@@ -2810,6 +2875,7 @@ systematically send encrypted emails when possible."
(define-key message-mode-map [remap split-line] 'message-split-line)
(define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
+ (define-key message-mode-map "\C-c\C-p" 'message-insert-screenshot)
(define-key message-mode-map "\C-a" 'message-beginning-of-line)
(define-key message-mode-map "\t" 'message-tab)
@@ -2839,6 +2905,8 @@ systematically send encrypted emails when possible."
:active (message-mark-active-p) :help "Mark region with enclosing tags"]
["Insert File Marked..." message-mark-insert-file
:help "Insert file at point marked with enclosing tags"]
+ ["Attach File..." mml-attach-file t]
+ ["Insert Screenshot" message-insert-screenshot t]
"----"
["Send Message" message-send-and-exit :help "Send this message"]
["Postpone Message" message-dont-send
@@ -6988,15 +7056,28 @@ want to get rid of this query permanently.")))
;; Build the header alist. Allow the user to be asked whether
;; or not to reply to all recipients in a wide reply.
- (setq follow-to (list (cons 'To (cdr (pop recipients)))))
- (when (and recipients
- (or (not message-wide-reply-confirm-recipients)
- (y-or-n-p "Reply to all recipients? ")))
- (setq recipients (mapconcat
- (lambda (addr) (cdr addr)) recipients ", "))
- (if (string-match "^ +" recipients)
- (setq recipients (substring recipients (match-end 0))))
- (push (cons 'Cc recipients) follow-to)))
+ (when (or (< (length recipients) 2)
+ (not message-wide-reply-confirm-recipients)
+ (y-or-n-p "Reply to all recipients? "))
+ (if never-mct
+ ;; The author has requested never to get a (wide)
+ ;; response, so put everybody else into the To header.
+ ;; This avoids looking as if we're To-in somebody else in
+ ;; specific, and just Cc-in the rest.
+ (setq follow-to (list
+ (cons 'To
+ (mapconcat
+ (lambda (addr)
+ (cdr addr)) recipients ", "))))
+ ;; Put the first recipient in the To header.
+ (setq follow-to (list (cons 'To (cdr (pop recipients)))))
+ ;; Put the rest of the recipients in Cc.
+ (when recipients
+ (setq recipients (mapconcat
+ (lambda (addr) (cdr addr)) recipients ", "))
+ (if (string-match "^ +" recipients)
+ (setq recipients (substring recipients (match-end 0))))
+ (push (cons 'Cc recipients) follow-to)))))
follow-to))
(defun message-prune-recipients (recipients)
@@ -8652,6 +8733,108 @@ Used in `message-simplify-recipients'."
(* 0.5 (- (nth 3 edges) (nth 1 edges)))))
string)))))))
+(defun message-insert-screenshot (delay)
+ "Take a screenshot and insert in the current buffer.
+DELAY (the numeric prefix) says how many seconds to wait before
+starting the screenshotting process.
+
+The `message-screenshot-command' variable says what command is
+used to take the screenshot."
+ (interactive "p")
+ (unless (executable-find (car message-screenshot-command))
+ (error "Can't find %s to take the screenshot"
+ (car message-screenshot-command)))
+ (cl-decf delay)
+ (unless (zerop delay)
+ (dotimes (i delay)
+ (message "Sleeping %d second%s..."
+ (- delay i)
+ (if (= (- delay i) 1)
+ ""
+ "s"))
+ (sleep-for 1)))
+ (message "Take screenshot")
+ (let ((image
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (apply #'call-process
+ (car message-screenshot-command) nil (current-buffer) nil
+ (cdr message-screenshot-command))
+ (buffer-string))))
+ (set-mark (point))
+ (insert-image
+ (create-image image 'png t
+ :max-width (truncate (* (frame-pixel-width) 0.8))
+ :max-height (truncate (* (frame-pixel-height) 0.8))
+ :scale 1)
+ (format "<#part type=\"image/png\" disposition=inline
data-encoding=base64 raw=t>\n%s\n<#/part>"
+ ;; Get a base64 version of the image -- this avoids later
+ ;; complications if we're auto-saving the buffer and
+ ;; restoring from a file.
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert image)
+ (base64-encode-region (point-min) (point-max) t)
+ (buffer-string))))
+ (insert "\n\n")
+ (message "")))
+
+(declare-function gnus-url-unhex-string "gnus-util")
+
+(defun message-parse-mailto-url (url)
+ "Parse a mailto: url."
+ (setq url (replace-regexp-in-string "\n" " " url))
+ (when (string-match "mailto:/*\\(.*\\)" url)
+ (setq url (substring url (match-beginning 1) nil)))
+ (setq url (if (string-match "^\\?" url)
+ (substring url 1)
+ (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
+ (concat "to=" (match-string 1 url) "&"
+ (match-string 2 url))
+ (concat "to=" url))))
+ (let (retval pairs cur key val)
+ (setq pairs (split-string url "&"))
+ (while pairs
+ (setq cur (car pairs)
+ pairs (cdr pairs))
+ (if (not (string-match "=" cur))
+ nil ; Grace
+ (setq key (downcase (gnus-url-unhex-string
+ (substring cur 0 (match-beginning 0))))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
+ retval))
+
+;;;###autoload
+(defun message-mailto ()
+ "Command to parse command line mailto: links.
+This is meant to be used for MIME handlers: Setting the handler
+for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\"
+will then start up Emacs ready to compose mail."
+ (interactive)
+ ;; <a
href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body";>Send
email</a>
+ (message-mail)
+ (message-mailto-1 (pop command-line-args-left)))
+
+(defun message-mailto-1 (url)
+ (let ((args (message-parse-mailto-url url)))
+ (dolist (arg args)
+ (unless (equal (car arg) "body")
+ (message-position-on-field (capitalize (car arg)))
+ (insert (replace-regexp-in-string
+ "\r\n" "\n"
+ (mapconcat #'identity (reverse (cdr arg)) ", ") nil t))))
+ (when (assoc "body" args)
+ (message-goto-body)
+ (dolist (body (cdr (assoc "body" args)))
+ (insert body "\n")))
+ (if (assoc "subject" args)
+ (message-goto-body)
+ (message-goto-subject))))
+
(provide 'message)
(run-hooks 'message-load-hook)
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 587c4e0..7f8ab5f 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1680,6 +1680,12 @@ If RECURSIVE, search recursively."
(t (y-or-n-p
(format "Decrypt (S/MIME) part? "))))
(mm-view-pkcs7 parts from))
+ (goto-char (point-min))
+ ;; The encrypted document is a MIME part, and may use either
+ ;; CRLF (Outlook and the like) or newlines for end-of-line
+ ;; markers. Translate from CRLF.
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
;; Normally there will be a Content-type header here, but
;; some mailers don't add that to the encrypted part, which
;; makes the subsequent re-dissection fail here.
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index 828ac63..bd5960c 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -59,11 +59,16 @@
"The attributes of renderer types for text/html.")
(defcustom mm-fill-flowed t
- "If non-nil a format=flowed article will be displayed flowed."
+ "If non-nil, format=flowed articles will be displayed flowed."
:type 'boolean
:version "22.1"
:group 'mime-display)
+;; Not a defcustom, since it's usually overridden by the callers of
+;; the mm functions.
+(defvar mm-inline-font-lock t
+ "If non-nil, do font locking of inline media types that support it.")
+
(defcustom mm-inline-large-images-proportion 0.9
"Maximum proportion large images can occupy in the buffer.
This is only used if `mm-inline-large-images' is set to
@@ -502,7 +507,8 @@ If MODE is not set, try to find mode automatically."
(delay-mode-hooks (set-auto-mode))
(setq mode major-mode)))
;; Do not fontify if the guess mode is fundamental.
- (unless (eq major-mode 'fundamental-mode)
+ (when (and (not (eq major-mode 'fundamental-mode))
+ mm-inline-font-lock)
(font-lock-ensure))))
(setq text (buffer-string))
(when (eq mode 'diff-mode)
diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el
index 740e1d2..69852c3 100644
--- a/lisp/gnus/mml-sec.el
+++ b/lisp/gnus/mml-sec.el
@@ -665,8 +665,9 @@ The passphrase is read and cached."
(epg-user-id-string uid))))
(equal (downcase (car (mail-header-parse-address
(epg-user-id-string uid))))
- (downcase (car (mail-header-parse-address
- recipient))))
+ (downcase (or (car (mail-header-parse-address
+ recipient))
+ recipient)))
(not (memq (epg-user-id-validity uid)
'(revoked expired))))
(throw 'break t))))))
@@ -937,6 +938,10 @@ If no one is selected, symmetric encryption will be
performed. "
(signal (car error) (cdr error))))
cipher))
+;; Should probably be removed and the interface should be different.
+(defvar mml-secure-allow-signing-with-unknown-recipient nil
+ "Variable to bind to allow automatic recipient selection.")
+
(defun mml-secure-epg-sign (protocol mode)
;; Based on code appearing inside mml2015-epg-sign.
(let* ((context (epg-make-context protocol))
@@ -953,7 +958,8 @@ If no one is selected, symmetric encryption will be
performed. "
;; then there's no point advising the user to examine it. If
;; there are any other variables worth examining, please
;; improve this error message by having it mention them.
- (error "Couldn't find any signer names%s" maybe-msg)))
+ (unless mml-secure-allow-signing-with-unknown-recipient
+ (error "Couldn't find any signer names%s" maybe-msg))))
(when (eq 'OpenPGP protocol)
(setf (epg-context-armor context) t)
(setf (epg-context-textmode context) t)
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 2149149..ef8aa6a 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -295,6 +295,17 @@ part. This is for the internal use, you should never
modify the value.")
(t
(mm-find-mime-charset-region point (point)
mm-hack-charsets))))
+ ;; We have a part that already has a transfer encoding. Undo
+ ;; that so that we don't double-encode later.
+ (when (and raw
+ (cdr (assq 'data-encoding tag)))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert contents)
+ (mm-decode-content-transfer-encoding
+ (intern (cdr (assq 'data-encoding tag)))
+ (cdr (assq 'type tag)))
+ (setq contents (buffer-string))))
(when (and (not raw) (memq nil charsets))
(if (or (memq 'unknown-encoding mml-confirmation-set)
(message-options-get 'unknown-encoding)
@@ -313,8 +324,8 @@ Message contains characters with unknown encoding. Really
send? ")
(eq 'mml (car tag))
(< (length charsets) 2))
(if (or (not no-markup-p)
+ ;; Don't create blank parts.
(string-match "[^ \t\r\n]" contents))
- ;; Don't create blank parts.
(push (nconc tag (list (cons 'contents contents)))
struct))
(let ((nstruct (mml-parse-singlepart-with-multiple-charsets
diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el
index fe6daf6..5500148 100644
--- a/lisp/gnus/smime.el
+++ b/lisp/gnus/smime.el
@@ -185,6 +185,9 @@ and the files themselves should be in PEM format."
:version "22.1"
:type '(choice (const :tag "Triple DES" "-des3")
(const :tag "DES" "-des")
+ (const :tag "AES 256 bits" "-aes256")
+ (const :tag "AES 192 bits" "-aes192")
+ (const :tag "AES 128 bits" "-aes128")
(const :tag "RC2 40 bits" "-rc2-40")
(const :tag "RC2 64 bits" "-rc2-64")
(const :tag "RC2 128 bits" "-rc2-128"))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 082a44d..d40b928 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1778,6 +1778,50 @@ documentation for the major and minor modes of that
buffer."
;; For the sake of IELM and maybe others
nil)
+;; Widgets.
+
+(defvar describe-widget-functions
+ '(button-describe widget-describe)
+ "A list of functions for `describe-widget' to call.
+Each function should take one argument, a buffer position, and return
+non-nil if it described a widget at that position.")
+
+;;;###autoload
+(defun describe-widget (&optional pos)
+ "Display a buffer with information about a widget.
+You can use this command to describe buttons (e.g., the links in a *Help*
+buffer), editable fields of the customization buffers, etc.
+
+Interactively, click on a widget to describe it, or hit RET to describe the
+widget at point.
+
+When called from Lisp, POS may be a buffer position or a mouse position list.
+
+Calls each function of the list `describe-widget-functions' in turn, until
+one of them returns non-nil."
+ (interactive
+ (list
+ (let ((key
+ (read-key
+ "Click on a widget, or hit RET to describe the widget at point")))
+ (cond ((eq key ?\C-m) (point))
+ ((and (mouse-event-p key)
+ (eq (event-basic-type key) 'mouse-1)
+ (equal (event-modifiers key) '(click)))
+ (event-end key))
+ ((eq key ?\C-g) (signal 'quit nil))
+ (t (user-error "You didn't specify a widget"))))))
+ (let (buf)
+ ;; Allow describing a widget in a different window.
+ (when (posnp pos)
+ (setq buf (window-buffer (posn-window pos))
+ pos (posn-point pos)))
+ (with-current-buffer (or buf (current-buffer))
+ (unless (cl-some (lambda (fun) (when (fboundp fun) (funcall fun pos)))
+ describe-widget-functions)
+ (message "No widget found at that position")))))
+
+
;;; Replacements for old lib-src/ programs. Don't seem especially useful.
;; Replaces lib-src/digest-doc.c.
diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index a183103..33ca40f 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -812,7 +812,9 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock
search."
(setq hi-lock-interactive-patterns
(cdr hi-lock-interactive-patterns)
hi-lock-interactive-lighters
- (cdr hi-lock-interactive-lighters)))))))))
+ (cdr hi-lock-interactive-lighters))))
+ (when (or (> search-start (point-min)) (< search-end (point-max)))
+ (message "Hi-lock added only in range %d-%d" search-start
search-end)))))))
(defun hi-lock-set-file-patterns (patterns)
"Replace file patterns list with PATTERNS and refontify."
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index bfb9787..c9ca1f8 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -504,7 +504,7 @@ format. See `ibuffer-update-saved-filters-format' and
(ibuffer-forward-line 0))
(defun ibuffer--maybe-erase-shell-cmd-output ()
- (let ((buf (get-buffer "*Shell Command Output*")))
+ (let ((buf (get-buffer shell-command-buffer-name)))
(when (and (buffer-live-p buf)
(not shell-command-dont-erase-buffer)
(not (zerop (buffer-size buf))))
@@ -517,7 +517,7 @@ format. See `ibuffer-update-saved-filters-format' and
:opstring "Shell command executed on"
:before (ibuffer--maybe-erase-shell-cmd-output)
:modifier-p nil)
- (let ((out-buf (get-buffer-create "*Shell Command Output*")))
+ (let ((out-buf (get-buffer-create shell-command-buffer-name)))
(with-current-buffer out-buf (goto-char (point-max)))
(call-shell-region (point-min) (point-max)
command nil out-buf)))
@@ -542,7 +542,7 @@ format. See `ibuffer-update-saved-filters-format' and
:modifier-p nil)
(let ((file (and (not (buffer-modified-p))
buffer-file-name))
- (out-buf (get-buffer-create "*Shell Command Output*")))
+ (out-buf (get-buffer-create shell-command-buffer-name)))
(unless (and file (file-exists-p file))
(setq file
(make-temp-file
diff --git a/lisp/image-file.el b/lisp/image-file.el
index 89cd75d..22366c8 100644
--- a/lisp/image-file.el
+++ b/lisp/image-file.el
@@ -32,6 +32,7 @@
;;; Code:
(require 'image)
+(require 'image-converter)
;;;###autoload
@@ -80,10 +81,13 @@ the variable is set using \\[customize]."
(let ((exts-regexp
(and image-file-name-extensions
(concat "\\."
- (regexp-opt (nconc (mapcar #'upcase
- image-file-name-extensions)
- image-file-name-extensions)
- t)
+ (regexp-opt
+ (append (mapcar #'upcase image-file-name-extensions)
+ image-file-name-extensions
+ (mapcar #'upcase
+ image-converter-file-name-extensions)
+ image-converter-file-name-extensions)
+ t)
"\\'"))))
(mapconcat
'identity
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 1bb213c..948e62e 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -40,6 +40,7 @@
(require 'image)
(require 'exif)
+(require 'dired)
(eval-when-compile (require 'cl-lib))
;;; Image mode window-info management.
@@ -614,21 +615,23 @@ Key bindings:
(if (not (image-get-display-property))
(progn
(when (condition-case err
- (progn
- (image-toggle-display-image)
- t)
- (unknown-image-type
- (image-mode-as-text)
- (funcall
- (if (called-interactively-p 'any) 'error 'message)
- "Unknown image type; consider switching
`image-use-external-converter' on")
- nil)
- (error
- (image-mode-as-text)
- (funcall
- (if (called-interactively-p 'any) 'error 'message)
- "Cannot display image: %s" (cdr err))
- nil))
+ (progn
+ (image-toggle-display-image)
+ t)
+ (unknown-image-type
+ (image-mode-as-text)
+ (funcall
+ (if (called-interactively-p 'any) 'error 'message)
+ (if image-use-external-converter
+ "Unknown image type"
+ "Unknown image type; consider switching
`image-use-external-converter' on"))
+ nil)
+ (error
+ (image-mode-as-text)
+ (funcall
+ (if (called-interactively-p 'any) 'error 'message)
+ "Cannot display image: %s" (cdr err))
+ nil))
;; If attempt to display the image fails.
(if (not (image-get-display-property))
(error "Invalid image"))
@@ -816,13 +819,21 @@ was inserted."
(- (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)))
(inhibit-read-only t)
(buffer-undo-list t)
(modified (buffer-modified-p))
- props image)
+ props image type)
+
+ ;; If the data in the current buffer isn't from an existing file,
+ ;; but we have a file name (this happens when visiting images from
+ ;; a zip file, for instance), provide a type hint based on the
+ ;; suffix.
+ (when (and data-p filename)
+ (setq data-p (intern (format "image/%s"
+ (file-name-extension filename)))))
+ (setq type (if (image--imagemagick-wanted-p filename)
+ 'imagemagick
+ (image-type file-or-data nil data-p)))
;; Get the rotation data from the file, if any.
(when (zerop image-transform-rotation) ; don't reset modified value
@@ -839,10 +850,13 @@ was inserted."
;; :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
+ :format (and filename data-p))
(create-image file-or-data type data-p :scale 1
:max-width max-width
- :max-height max-height)))
+ :max-height max-height
+ ;; Type hint.
+ :format (and filename data-p))))
;; Discard any stale image data before looking it up again.
(image-flush image)
@@ -1072,28 +1086,87 @@ replacing the current Image mode buffer."
(error "The buffer is not in Image mode"))
(unless buffer-file-name
(error "The current image is not associated with a file"))
- (let* ((file (file-name-nondirectory buffer-file-name))
- (images (image-mode--images-in-directory file))
- (idx 0))
- (catch 'image-visit-next-file
- (dolist (f images)
- (if (string= f file)
- (throw 'image-visit-next-file (1+ idx)))
- (setq idx (1+ idx))))
- (setq idx (mod (+ idx (or n 1)) (length images)))
- (let ((image (nth idx images))
- (dir (file-name-directory buffer-file-name)))
- (find-alternate-file image)
- ;; If we have dired buffer(s) open to where this image is, then
- ;; place point on it.
+ (let ((next (image-mode--next-file buffer-file-name n)))
+ (unless next
+ (user-error "No %s file in this directory"
+ (if (> n 0)
+ "next"
+ "prev")))
+ (if (stringp next)
+ (find-alternate-file next)
+ (funcall next))))
+
+(defun image-mode--directory-buffers (file)
+ "Return a alist of type/buffer for all \"parent\" buffers to image FILE.
+This is normally a list of dired buffers, but can also be archive and
+tar mode buffers."
+ (let ((buffers nil)
+ (dir (file-name-directory file)))
+ (cond
+ ((and (boundp 'tar-superior-buffer)
+ tar-superior-buffer)
+ (when (buffer-live-p tar-superior-buffer)
+ (push (cons 'tar tar-superior-buffer) buffers)))
+ ((and (boundp 'archive-superior-buffer)
+ archive-superior-buffer)
+ (when (buffer-live-p archive-superior-buffer)
+ (push (cons 'archive archive-superior-buffer) buffers)))
+ (t
+ ;; Find a dired buffer.
(dolist (buffer (buffer-list))
- (with-current-buffer buffer
- (when (and (derived-mode-p 'dired-mode)
+ (with-current-buffer buffer
+ (when (and (derived-mode-p 'dired-mode)
(equal (file-truename dir)
(file-truename default-directory)))
- (save-window-excursion
- (switch-to-buffer (current-buffer) t t)
- (dired-goto-file (expand-file-name image dir)))))))))
+ (push (cons 'dired (current-buffer)) buffers))))
+ ;; If we can't find any buffers to navigate in, we open a dired
+ ;; buffer.
+ (unless buffers
+ (push (cons 'dired (find-file-noselect dir)) buffers)
+ (message "Opened a dired buffer on %s" dir))))
+ buffers))
+
+(declare-function archive-next-file-displayer "arc-mode")
+(declare-function tar-next-file-displayer "tar-mode")
+
+(defun image-mode--next-file (file n)
+ "Go to the next image file in the parent buffer of FILE.
+This is typically a dired buffer, but may also be a tar/archive buffer.
+Return the next image file from that buffer.
+If N is negative, go to the previous file."
+ (let ((regexp (image-file-name-regexp))
+ (buffers (image-mode--directory-buffers file))
+ next)
+ (dolist (buffer buffers)
+ ;; We do this traversal for all the dired buffers open on this
+ ;; directory. There probably is just one, but we want to move
+ ;; point in all of them.
+ (save-window-excursion
+ (switch-to-buffer (cdr buffer) t t)
+ (cl-case (car buffer)
+ ('dired
+ (dired-goto-file file)
+ (let (found)
+ (while (and (not found)
+ ;; Stop if we reach the end/start of the buffer.
+ (if (> n 0)
+ (not (eobp))
+ (not (bobp))))
+ (dired-next-line n)
+ (let ((candidate (dired-get-filename nil t)))
+ (when (and candidate
+ (string-match-p regexp candidate))
+ (setq found candidate))))
+ (if found
+ (setq next found)
+ ;; If we didn't find a next/prev file, then restore
+ ;; point.
+ (dired-goto-file file))))
+ ('archive
+ (setq next (archive-next-file-displayer file regexp n)))
+ ('tar
+ (setq next (tar-next-file-displayer file regexp n))))))
+ next))
(defun image-previous-file (&optional n)
"Visit the preceding image in the same directory as the current file.
diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el
index b694052..ee1dc84 100644
--- a/lisp/image/image-converter.el
+++ b/lisp/image/image-converter.el
@@ -42,6 +42,9 @@ installed on the system."
(defvar image-converter-regexp nil
"A regexp that matches the file name suffixes that can be converted.")
+(defvar image-converter-file-name-extensions nil
+ "A list of file name suffixes that can be converted.")
+
(defvar image-converter--converters
'((graphicsmagick :command ("gm" "convert") :probe ("-list" "format"))
(ffmpeg :command "ffmpeg" :probe "-decoders")
@@ -58,9 +61,11 @@ is a string, it should be a MIME format string like
(unless image-converter
(image-converter--find-converter))
;; When image-converter was customized
- (if (and image-converter (not image-converter-regexp))
- (when-let ((formats (image-converter--probe image-converter)))
- (setq image-converter-regexp (concat "\\." (regexp-opt formats)
"\\'"))))
+ (when (and image-converter (not image-converter-regexp))
+ (when-let ((formats (image-converter--probe image-converter)))
+ (setq image-converter-regexp
+ (concat "\\." (regexp-opt formats) "\\'"))
+ (setq image-converter-file-name-extensions formats)))
(and image-converter
(or (and (not data-p)
(string-match image-converter-regexp source))
@@ -183,7 +188,8 @@ data is returned as a string."
(dolist (elem image-converter--converters)
(when-let ((formats (image-converter--probe (car elem))))
(setq image-converter (car elem)
- image-converter-regexp (concat "\\." (regexp-opt formats) "\\'"))
+ image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")
+ image-converter-file-name-extensions formats)
(throw 'done image-converter)))))
(cl-defmethod image-converter--convert ((type (eql graphicsmagick)) source
diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el
index 45e1346..f5e70ce 100644
--- a/lisp/international/ja-dic-cnv.el
+++ b/lisp/international/ja-dic-cnv.el
@@ -48,7 +48,7 @@
(defvar ja-dic-filename "ja-dic.el")
(defun skkdic-convert-okuri-ari (skkbuf buf)
- (byte-compile-info-message "Processing OKURI-ARI entries")
+ (byte-compile-info "Processing OKURI-ARI entries" t)
(goto-char (point-min))
(with-current-buffer buf
(insert ";; Setting okuri-ari entries.\n"
@@ -97,7 +97,7 @@
("ゆき" "行")))
(defun skkdic-convert-postfix (skkbuf buf)
- (byte-compile-info-message "Processing POSTFIX entries")
+ (byte-compile-info "Processing POSTFIX entries" t)
(goto-char (point-min))
(with-current-buffer buf
(insert ";; Setting postfix entries.\n"
@@ -151,7 +151,7 @@
(defconst skkdic-prefix-list '(skkdic-prefix-list))
(defun skkdic-convert-prefix (skkbuf buf)
- (byte-compile-info-message "Processing PREFIX entries")
+ (byte-compile-info "Processing PREFIX entries" t)
(goto-char (point-min))
(with-current-buffer buf
(insert ";; Setting prefix entries.\n"
@@ -273,7 +273,7 @@
(defun skkdic-collect-okuri-nasi ()
(save-excursion
(let ((progress (make-progress-reporter
- (byte-compile-info-message "Collecting OKURI-NASI
entries")
+ (byte-compile-info "Collecting OKURI-NASI entries" t)
(point) (point-max)
nil 10)))
(while (re-search-forward "^\\(\\cH+\\) \\(/\\cj.*\\)/$"
@@ -301,7 +301,7 @@
"(skkdic-set-okuri-nasi\n")
(let ((l (nreverse skkdic-okuri-nasi-entries))
(progress (make-progress-reporter
- (byte-compile-info-message "Processing OKURI-NASI
entries")
+ (byte-compile-info "Processing OKURI-NASI entries" t)
0 skkdic-okuri-nasi-entries-count
nil 10))
(count 0))
@@ -531,8 +531,7 @@ To get complete usage, invoke:
',(let ((l entries)
(map '(skdic-okuri-nasi))
(progress (make-progress-reporter
- (byte-compile-info-message
- "Extracting OKURI-NASI entries")
+ (byte-compile-info "Extracting OKURI-NASI entries")
0 (length entries)))
(count 0)
entry)
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 640f10a..d369545 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -49,7 +49,10 @@
"If non-nil, copy to kill-ring upon mouse adjustments of the region.
This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in
-addition to mouse drags."
+addition to mouse drags.
+
+This variable applies only to mouse adjustments in Emacs, not
+selecting and adjusting regions in other windows."
:type 'boolean
:version "24.1")
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 8892e80..2b8d4d0 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -1,4 +1,4 @@
-;;; browse-url.el --- pass a URL to a WWW browser
+;;; browse-url.el --- pass a URL to a WWW browser -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2020 Free Software Foundation, Inc.
@@ -425,25 +425,6 @@ Passing an interactive argument to \\[browse-url], or
specific browser
commands reverses the effect of this variable."
:type 'boolean)
-(defcustom browse-url-mosaic-program "xmosaic"
- "The name by which to invoke Mosaic (or mMosaic)."
- :type 'string
- :version "20.3")
-
-(make-obsolete-variable 'browse-url-mosaic-program nil "25.1")
-
-(defcustom browse-url-mosaic-arguments nil
- "A list of strings to pass to Mosaic as arguments."
- :type '(repeat (string :tag "Argument")))
-
-(make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1")
-
-(defcustom browse-url-mosaic-pidfile "~/.mosaicpid"
- "The name of the pidfile created by Mosaic."
- :type 'string)
-
-(make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1")
-
(defcustom browse-url-conkeror-program "conkeror"
"The name by which to invoke Conkeror."
:type 'string
@@ -498,22 +479,6 @@ Used by the `browse-url-of-file' command."
"Hook run after `browse-url-of-file' has asked a browser to load a file."
:type 'hook)
-(defcustom browse-url-CCI-port 3003
- "Port to access XMosaic via CCI.
-This can be any number between 1024 and 65535 but must correspond to
-the value set in the browser."
- :type 'integer)
-
-(make-obsolete-variable 'browse-url-CCI-port nil "25.1")
-
-(defcustom browse-url-CCI-host "localhost"
- "Host to access XMosaic via CCI.
-This should be the host name of the machine running XMosaic with CCI
-enabled. The port number should be set in `browse-url-CCI-port'."
- :type 'string)
-
-(make-obsolete-variable 'browse-url-CCI-host nil "25.1")
-
(defvar browse-url-temp-file-name nil)
(make-variable-buffer-local 'browse-url-temp-file-name)
@@ -622,7 +587,7 @@ process), or nil (we don't know)."
kind)))
(defun browse-url--mailto (url &rest args)
- "Calls `browse-url-mailto-function' with URL and ARGS."
+ "Call `browse-url-mailto-function' with URL and ARGS."
(funcall browse-url-mailto-function url args))
(defun browse-url--browser-kind-mailto (url)
@@ -631,7 +596,7 @@ process), or nil (we don't know)."
#'browse-url--browser-kind-mailto)
(defun browse-url--man (url &rest args)
- "Calls `browse-url-man-function' with URL and ARGS."
+ "Call `browse-url-man-function' with URL and ARGS."
(funcall browse-url-man-function url args))
(defun browse-url--browser-kind-man (url)
@@ -640,7 +605,7 @@ process), or nil (we don't know)."
#'browse-url--browser-kind-man)
(defun browse-url--browser (url &rest args)
- "Calls `browse-url-browser-function' with URL and ARGS."
+ "Call `browse-url-browser-function' with URL and ARGS."
(funcall browse-url-browser-function url args))
(defun browse-url--browser-kind-browser (url)
@@ -854,8 +819,8 @@ narrowed."
(browse-url-of-file file-name))))
(defun browse-url-delete-temp-file (&optional temp-file-name)
- ;; Delete browse-url-temp-file-name from the file system
- ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead
+ "Delete `browse-url-temp-file-name' from the file system.
+If optional arg TEMP-FILE-NAME is non-nil, delete it instead."
(let ((file-name (or temp-file-name browse-url-temp-file-name)))
(if (and file-name (file-exists-p file-name))
(delete-file file-name))))
@@ -1075,8 +1040,6 @@ instead of `browse-url-new-window-flag'."
;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon)
((executable-find browse-url-kde-program) 'browse-url-kde)
;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape)
-;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic)
-;;; ((executable-find browse-url-conkeror-program) 'browse-url-conkeror)
((executable-find browse-url-chrome-program) 'browse-url-chrome)
((executable-find browse-url-xterm-program) 'browse-url-text-xterm)
((locate-library "w3") 'browse-url-w3)
@@ -1444,93 +1407,6 @@ used instead of `browse-url-new-window-flag'."
(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external)
-;; --- Mosaic ---
-
-;;;###autoload
-(defun browse-url-mosaic (url &optional new-window)
- "Ask the XMosaic WWW browser to load URL.
-
-Default to the URL around or before point. The strings in variable
-`browse-url-mosaic-arguments' are also passed to Mosaic and the
-program is invoked according to the variable
-`browse-url-mosaic-program'.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new Mosaic window, otherwise use a
-random existing one. A non-nil interactive prefix argument reverses
-the effect of `browse-url-new-window-flag'.
-
-When called non-interactively, optional second argument NEW-WINDOW is
-used instead of `browse-url-new-window-flag'."
- (declare (obsolete nil "25.1"))
- (interactive (browse-url-interactive-arg "Mosaic URL: "))
- (let ((pidfile (expand-file-name browse-url-mosaic-pidfile))
- pid)
- (if (file-readable-p pidfile)
- (with-temp-buffer
- (insert-file-contents pidfile)
- (setq pid (read (current-buffer)))))
- (if (and (integerp pid) (zerop (signal-process pid 0))) ; Mosaic running
- (progn
- (with-temp-buffer
- (insert (if (browse-url-maybe-new-window new-window)
- "newwin\n"
- "goto\n")
- url "\n")
- (with-file-modes ?\700
- (if (file-exists-p
- (setq pidfile (format "/tmp/Mosaic.%d" pid)))
- (delete-file pidfile))
- ;; https://debbugs.gnu.org/17428. Use O_EXCL.
- (write-region nil nil pidfile nil 'silent nil 'excl)))
- ;; Send signal SIGUSR to Mosaic
- (message "Signaling Mosaic...")
- (signal-process pid 'SIGUSR1)
- ;; Or you could try:
- ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid))
- (message "Signaling Mosaic...done"))
- ;; Mosaic not running - start it
- (message "Starting %s..." browse-url-mosaic-program)
- (apply 'start-process "xmosaic" nil browse-url-mosaic-program
- (append browse-url-mosaic-arguments (list url)))
- (message "Starting %s...done" browse-url-mosaic-program))))
-
-(function-put 'browse-url-mosaic 'browse-url-browser-kind 'external)
-
-;; --- Mosaic using CCI ---
-
-;;;###autoload
-(defun browse-url-cci (url &optional new-window)
- "Ask the XMosaic WWW browser to load URL.
-Default to the URL around or before point.
-
-This function only works for XMosaic version 2.5 or later. You must
-select `CCI' from XMosaic's File menu, set the CCI Port Address to the
-value of variable `browse-url-CCI-port', and enable `Accept requests'.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new browser window, otherwise use a
-random existing one. A non-nil interactive prefix argument reverses
-the effect of `browse-url-new-window-flag'.
-
-When called non-interactively, optional second argument NEW-WINDOW is
-used instead of `browse-url-new-window-flag'."
- (declare (obsolete nil "25.1"))
- (interactive (browse-url-interactive-arg "Mosaic URL: "))
- (open-network-stream "browse-url" " *browse-url*"
- browse-url-CCI-host browse-url-CCI-port)
- ;; Todo: start browser if fails
- (process-send-string "browse-url"
- (concat "get url (" url ") output "
- (if (browse-url-maybe-new-window new-window)
- "new"
- "current")
- "\r\n"))
- (process-send-string "browse-url" "disconnect\r\n")
- (delete-process "browse-url"))
-
-(function-put 'browse-url-cci 'browse-url-browser-kind 'external)
-
;; --- Conkeror ---
;;;###autoload
(defun browse-url-conkeror (url &optional new-window)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index edb2f72..e7170b3 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -277,6 +277,24 @@ This list can be customized via `eww-suggest-uris'."
(nreverse uris)))
;;;###autoload
+(defun eww-browse ()
+ "Function to be run to parse command line URLs.
+This is meant to be used for MIME handlers or command line use.
+
+Setting the handler for \"text/x-uri;\" to
+\"emacs -f eww-browse %u\" will then start up Emacs and call eww
+to browse the url.
+
+This can also be used on the command line directly:
+
+ emacs -f eww-browse https://gnu.org
+
+will start Emacs and browse the GNU web site."
+ (interactive)
+ (eww (pop command-line-args-left)))
+
+
+;;;###autoload
(defun eww (url &optional arg buffer)
"Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 7e5af69..88f5c29 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -96,8 +96,10 @@ It is used for TCP/IP devices."
(tramp--with-startup
(add-to-list 'tramp-methods
`(,tramp-adb-method
- (tramp-tmpdir "/data/local/tmp")
- (tramp-default-port 5555)))
+ (tramp-login-program ,tramp-adb-program)
+ (tramp-login-args (("shell")))
+ (tramp-tmpdir "/data/local/tmp")
+ (tramp-default-port 5555)))
(add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil ""))
@@ -885,158 +887,163 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
;; The complete STDERR buffer is available only when the process has
;; terminated.
(defun tramp-adb-handle-make-process (&rest args)
- "Like `make-process' for Tramp files."
- (when args
- (with-parsed-tramp-file-name (expand-file-name default-directory) nil
- (let ((name (plist-get args :name))
- (buffer (plist-get args :buffer))
- (command (plist-get args :command))
- (coding (plist-get args :coding))
- (noquery (plist-get args :noquery))
- (connection-type (plist-get args :connection-type))
- (filter (plist-get args :filter))
- (sentinel (plist-get args :sentinel))
- (stderr (plist-get args :stderr)))
- (unless (stringp name)
- (signal 'wrong-type-argument (list #'stringp name)))
- (unless (or (null buffer) (bufferp buffer) (stringp buffer))
- (signal 'wrong-type-argument (list #'stringp buffer)))
- (unless (consp command)
- (signal 'wrong-type-argument (list #'consp command)))
- (unless (or (null coding)
- (and (symbolp coding) (memq coding coding-system-list))
- (and (consp coding)
- (memq (car coding) coding-system-list)
- (memq (cdr coding) coding-system-list)))
- (signal 'wrong-type-argument (list #'symbolp coding)))
- (unless (or (null connection-type) (memq connection-type '(pipe pty)))
- (signal 'wrong-type-argument (list #'symbolp connection-type)))
- (unless (or (null filter) (functionp filter))
- (signal 'wrong-type-argument (list #'functionp filter)))
- (unless (or (null sentinel) (functionp sentinel))
- (signal 'wrong-type-argument (list #'functionp sentinel)))
- (unless (or (null stderr) (bufferp stderr) (stringp stderr))
- (signal 'wrong-type-argument (list #'stringp stderr)))
- (when (and (stringp stderr) (tramp-tramp-file-p stderr)
- (not (tramp-equal-remote default-directory stderr)))
- (signal 'file-error (list "Wrong stderr" stderr)))
-
- (let* ((buffer
- (if buffer
- (get-buffer-create buffer)
- ;; BUFFER can be nil. We use a temporary buffer.
- (generate-new-buffer tramp-temp-buffer-name)))
- ;; STDERR can also be a file name.
- (tmpstderr
- (and stderr
- (if (and (stringp stderr) (tramp-tramp-file-p stderr))
- (tramp-unquote-file-local-name stderr)
- (tramp-make-tramp-temp-file v))))
- (remote-tmpstderr
- (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
- (program (car command))
- (args (cdr command))
- (command
- (format "cd %s && exec %s %s"
- (tramp-shell-quote-argument localname)
- (if tmpstderr (format "2>'%s'" tmpstderr) "")
- (mapconcat #'tramp-shell-quote-argument
- (cons program args) " ")))
- (tramp-process-connection-type
- (or (null program) tramp-process-connection-type))
- (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
- (name1 name)
- (i 0))
-
- (while (get-process name1)
- ;; NAME must be unique as process name.
- (setq i (1+ i)
- name1 (format "%s<%d>" name i)))
- (setq name name1)
- ;; Set the new process properties.
- (tramp-set-connection-property v "process-name" name)
- (tramp-set-connection-property v "process-buffer" buffer)
-
- (with-current-buffer (tramp-get-connection-buffer v)
- (unwind-protect
- ;; We catch this event. Otherwise, `make-process'
- ;; could be called on the local host.
- (save-excursion
- (save-restriction
- ;; Activate narrowing in order to save BUFFER
- ;; contents. Clear also the modification time;
- ;; otherwise we might be interrupted by
- ;; `verify-visited-file-modtime'.
- (let ((buffer-undo-list t)
- (inhibit-read-only t))
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max))
- ;; We call `tramp-adb-maybe-open-connection', in
- ;; order to cleanup the prompt afterwards.
- (tramp-adb-maybe-open-connection v)
- (delete-region (point-min) (point-max))
- ;; Send the command.
- (let* ((p (tramp-get-connection-process v)))
- (tramp-adb-send-command v command nil t) ; nooutput
- ;; Set sentinel and filter.
- (when sentinel
- (set-process-sentinel p sentinel))
- (when filter
- (set-process-filter p filter))
- ;; Set query flag and process marker for this
- ;; process. We ignore errors, because the
- ;; process could have finished already.
- (ignore-errors
- (set-process-query-on-exit-flag p (null noquery))
- (set-marker (process-mark p) (point)))
- ;; We must flush them here already; otherwise
- ;; `rename-file', `delete-file' or
- ;; `insert-file-contents' will fail.
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer")
- ;; Copy tmpstderr file.
- (when (and (stringp stderr)
- (not (tramp-tramp-file-p stderr)))
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (rename-file remote-tmpstderr stderr))))
- ;; Read initial output. Remove the first line,
- ;; which is the command echo.
- (while
- (progn
- (goto-char (point-min))
- (not (re-search-forward "[\n]" nil t)))
- (tramp-accept-process-output p 0))
- (delete-region (point-min) (point))
- ;; Provide error buffer. This shows only
- ;; initial error messages; messages arriving
- ;; later on will be inserted when the process
- ;; is deleted. The temporary file will exist
- ;; until the process is deleted.
- (when (bufferp stderr)
- (with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr 'visit))
- ;; 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))))
- ;; Return process.
- p))))
-
- ;; Save exit.
- (if (string-match-p tramp-temp-buffer-name (buffer-name))
- (ignore-errors
- (set-process-buffer (tramp-get-connection-process v) nil)
- (kill-buffer (current-buffer)))
- (set-buffer-modified-p bmp))
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer"))))))))
+ "Like `make-process' for Tramp files.
+If connection property \"direct-async-process\" is non-nil, an
+alternative implementation will be used."
+ (if (tramp-get-connection-property
+ (tramp-dissect-file-name default-directory) "direct-async-process" nil)
+ (apply #'tramp-handle-make-process args)
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'stringp stderr)))
+ (when (and (stringp stderr) (tramp-tramp-file-p stderr)
+ (not (tramp-equal-remote default-directory stderr)))
+ (signal 'file-error (list "Wrong stderr" stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ ;; STDERR can also be a file name.
+ (tmpstderr
+ (and stderr
+ (if (and (stringp stderr) (tramp-tramp-file-p stderr))
+ (tramp-unquote-file-local-name stderr)
+ (tramp-make-tramp-temp-file v))))
+ (remote-tmpstderr
+ (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
+ (program (car command))
+ (args (cdr command))
+ (command
+ (format "cd %s && exec %s %s"
+ (tramp-shell-quote-argument localname)
+ (if tmpstderr (format "2>'%s'" tmpstderr) "")
+ (mapconcat #'tramp-shell-quote-argument
+ (cons program args) " ")))
+ (tramp-process-connection-type
+ (or (null program) tramp-process-connection-type))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0))
+
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
+
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ ;; We catch this event. Otherwise, `make-process'
+ ;; could be called on the local host.
+ (save-excursion
+ (save-restriction
+ ;; Activate narrowing in order to save BUFFER
+ ;; contents. Clear also the modification time;
+ ;; otherwise we might be interrupted by
+ ;; `verify-visited-file-modtime'.
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (clear-visited-file-modtime)
+ (narrow-to-region (point-max) (point-max))
+ ;; We call `tramp-adb-maybe-open-connection',
+ ;; in order to cleanup the prompt afterwards.
+ (tramp-adb-maybe-open-connection v)
+ (delete-region (point-min) (point-max))
+ ;; Send the command.
+ (let* ((p (tramp-get-connection-process v)))
+ (tramp-adb-send-command v command nil t) ; nooutput
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for
+ ;; this process. We ignore errors, because
+ ;; the process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; We must flush them here already;
+ ;; otherwise `rename-file', `delete-file' or
+ ;; `insert-file-contents' will fail.
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
+ ;; Copy tmpstderr file.
+ (when (and (stringp stderr)
+ (not (tramp-tramp-file-p stderr)))
+ (add-function
+ :after (process-sentinel p)
+ (lambda (_proc _msg)
+ (rename-file remote-tmpstderr stderr))))
+ ;; Read initial output. Remove the first
+ ;; line, which is the command echo.
+ (while
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward "[\n]" nil t)))
+ (tramp-accept-process-output p 0))
+ (delete-region (point-min) (point))
+ ;; Provide error buffer. This shows only
+ ;; initial error messages; messages arriving
+ ;; later on will be inserted when the
+ ;; process is deleted. The temporary file
+ ;; will exist until the process is deleted.
+ (when (bufferp stderr)
+ (with-current-buffer stderr
+ (insert-file-contents-literally
+ remote-tmpstderr 'visit))
+ ;; 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))))
+ ;; Return process.
+ p))))
+
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer (tramp-get-connection-process v) nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")))))))))
(defun tramp-adb-handle-exec-path ()
"Like `exec-path' for Tramp files."
@@ -1253,6 +1260,14 @@ connection if a previous connection has died for some
reason."
(tramp-adb-send-command
vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt))
+ ;; Disable line editing.
+ (tramp-adb-send-command
+ vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
+
+ ;; Dump option settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-adb-send-command vec "set -o"))
+
;; Check whether the properties have been changed. If
;; yes, this is a strong indication that we must expire all
;; connection properties. We start again.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index f9f0cbc..3e2eb02 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -2787,228 +2787,233 @@ the result will be a local, non-Tramp, file name."
;; terminated.
(defun tramp-sh-handle-make-process (&rest args)
"Like `make-process' for Tramp files.
-STDERR can also be a file name."
- (when args
- (with-parsed-tramp-file-name (expand-file-name default-directory) nil
- (let ((name (plist-get args :name))
- (buffer (plist-get args :buffer))
- (command (plist-get args :command))
- (coding (plist-get args :coding))
- (noquery (plist-get args :noquery))
- (connection-type (plist-get args :connection-type))
- (filter (plist-get args :filter))
- (sentinel (plist-get args :sentinel))
- (stderr (plist-get args :stderr)))
- (unless (stringp name)
- (signal 'wrong-type-argument (list #'stringp name)))
- (unless (or (null buffer) (bufferp buffer) (stringp buffer))
- (signal 'wrong-type-argument (list #'stringp buffer)))
- (unless (consp command)
- (signal 'wrong-type-argument (list #'consp command)))
- (unless (or (null coding)
- (and (symbolp coding) (memq coding coding-system-list))
- (and (consp coding)
- (memq (car coding) coding-system-list)
- (memq (cdr coding) coding-system-list)))
- (signal 'wrong-type-argument (list #'symbolp coding)))
- (unless (or (null connection-type) (memq connection-type '(pipe pty)))
- (signal 'wrong-type-argument (list #'symbolp connection-type)))
- (unless (or (null filter) (functionp filter))
- (signal 'wrong-type-argument (list #'functionp filter)))
- (unless (or (null sentinel) (functionp sentinel))
- (signal 'wrong-type-argument (list #'functionp sentinel)))
- (unless (or (null stderr) (bufferp stderr) (stringp stderr))
- (signal 'wrong-type-argument (list #'stringp stderr)))
- (when (and (stringp stderr) (tramp-tramp-file-p stderr)
- (not (tramp-equal-remote default-directory stderr)))
- (signal 'file-error (list "Wrong stderr" stderr)))
-
- (let* ((buffer
- (if buffer
- (get-buffer-create buffer)
- ;; BUFFER can be nil. We use a temporary buffer.
- (generate-new-buffer tramp-temp-buffer-name)))
- ;; STDERR can also be a file name.
- (tmpstderr
- (and stderr
- (if (and (stringp stderr) (tramp-tramp-file-p stderr))
- (tramp-unquote-file-local-name stderr)
- (tramp-make-tramp-temp-file v))))
- (remote-tmpstderr
- (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
- (program (car command))
- (args (cdr command))
- ;; When PROGRAM matches "*sh", and the first arg is
- ;; "-c", it might be that the arguments exceed the
- ;; command line length. Therefore, we modify the
- ;; command.
- (heredoc (and (stringp program)
- (string-match-p "sh$" program)
- (string-equal "-c" (car args))
- (= (length args) 2)))
- ;; When PROGRAM is nil, we just provide a tty.
- (args (if (not heredoc) args
- (let ((i 250))
- (while (and (< i (length (cadr args)))
- (string-match " " (cadr args) i))
- (setcdr
- args
- (list
- (replace-match " \\\\\n" nil nil (cadr args))))
- (setq i (+ i 250))))
- (cdr args)))
- ;; Use a human-friendly prompt, for example for
- ;; `shell'. We discard hops, if existing, that's why
- ;; we cannot use `file-remote-p'.
- (prompt (format "PS1=%s %s"
- (tramp-make-tramp-file-name v nil 'nohop)
- tramp-initial-end-of-output))
- ;; We use as environment the difference to toplevel
- ;; `process-environment'.
- env uenv
- (env (dolist (elt (cons prompt process-environment) env)
- (or (member
- elt (default-toplevel-value 'process-environment))
- (if (string-match-p "=" elt)
- (setq env (append env `(,elt)))
- (if (tramp-get-env-with-u-option v)
- (setq env (append `("-u" ,elt) env))
- (setq uenv (cons elt uenv)))))))
- (command
- (when (stringp program)
- (setenv-internal
- env "INSIDE_EMACS"
- (concat (or (getenv "INSIDE_EMACS") emacs-version)
- ",tramp:" tramp-version)
- 'keep)
- (format "cd %s && %s exec %s %s env %s %s"
- (tramp-shell-quote-argument localname)
- (if uenv
- (format
- "unset %s &&"
- (mapconcat
- #'tramp-shell-quote-argument uenv " "))
- "")
- (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "")
- (if tmpstderr (format "2>'%s'" tmpstderr) "")
- (mapconcat #'tramp-shell-quote-argument env " ")
- (if heredoc
- (format "%s\n(\n%s\n) </dev/tty\n%s"
- program (car args) tramp-end-of-heredoc)
- (mapconcat #'tramp-shell-quote-argument
- (cons program args) " ")))))
- (tramp-process-connection-type
- (or (null program) tramp-process-connection-type))
- (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
- (name1 name)
- (i 0)
- ;; We do not want to raise an error when `make-process'
- ;; has been started several times in `eshell' and
- ;; friends.
- tramp-current-connection
- p)
-
- (while (get-process name1)
- ;; NAME must be unique as process name.
- (setq i (1+ i)
- name1 (format "%s<%d>" name i)))
- (setq name name1)
- ;; Set the new process properties.
- (tramp-set-connection-property v "process-name" name)
- (tramp-set-connection-property v "process-buffer" buffer)
-
- (with-current-buffer (tramp-get-connection-buffer v)
- (unwind-protect
- ;; We catch this event. Otherwise, `make-process' could
- ;; be called on the local host.
- (save-excursion
- (save-restriction
- ;; Activate narrowing in order to save BUFFER
- ;; contents. Clear also the modification time;
- ;; otherwise we might be interrupted by
- ;; `verify-visited-file-modtime'.
- (let ((buffer-undo-list t)
- (inhibit-read-only t)
- (mark (point-max)))
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max))
- ;; We call `tramp-maybe-open-connection', in
- ;; order to cleanup the prompt afterwards.
- (catch 'suppress
- (tramp-maybe-open-connection v)
- (setq p (tramp-get-connection-process v))
- ;; Set the pid of the remote shell. This is
- ;; needed when sending signals remotely.
- (let ((pid (tramp-send-command-and-read v "echo $$")))
- (process-put p 'remote-pid pid)
- (tramp-set-connection-property p "remote-pid" pid))
- ;; `tramp-maybe-open-connection' and
- ;; `tramp-send-command-and-read' could have
- ;; trashed the connection buffer. Remove this.
- (widen)
- (delete-region mark (point-max))
+STDERR can also be a file name. If connection property
+\"direct-async-process\" is non-nil, an alternative
+implementation will be used."
+ (if (tramp-get-connection-property
+ (tramp-dissect-file-name default-directory) "direct-async-process" nil)
+ (apply #'tramp-handle-make-process args)
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'stringp stderr)))
+ (when (and (stringp stderr) (tramp-tramp-file-p stderr)
+ (not (tramp-equal-remote default-directory stderr)))
+ (signal 'file-error (list "Wrong stderr" stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ ;; STDERR can also be a file name.
+ (tmpstderr
+ (and stderr
+ (if (and (stringp stderr) (tramp-tramp-file-p stderr))
+ (tramp-unquote-file-local-name stderr)
+ (tramp-make-tramp-temp-file v))))
+ (remote-tmpstderr
+ (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
+ (program (car command))
+ (args (cdr command))
+ ;; When PROGRAM matches "*sh", and the first arg is
+ ;; "-c", it might be that the arguments exceed the
+ ;; command line length. Therefore, we modify the
+ ;; command.
+ (heredoc (and (stringp program)
+ (string-match-p "sh$" program)
+ (string-equal "-c" (car args))
+ (= (length args) 2)))
+ ;; When PROGRAM is nil, we just provide a tty.
+ (args (if (not heredoc) args
+ (let ((i 250))
+ (while (and (< i (length (cadr args)))
+ (string-match " " (cadr args) i))
+ (setcdr
+ args
+ (list
+ (replace-match " \\\\\n" nil nil (cadr args))))
+ (setq i (+ i 250))))
+ (cdr args)))
+ ;; Use a human-friendly prompt, for example for
+ ;; `shell'. We discard hops, if existing, that's why
+ ;; we cannot use `file-remote-p'.
+ (prompt (format "PS1=%s %s"
+ (tramp-make-tramp-file-name v nil 'nohop)
+ tramp-initial-end-of-output))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ env uenv
+ (env (dolist (elt (cons prompt process-environment) env)
+ (or (member
+ elt (default-toplevel-value 'process-environment))
+ (if (string-match-p "=" elt)
+ (setq env (append env `(,elt)))
+ (if (tramp-get-env-with-u-option v)
+ (setq env (append `("-u" ,elt) env))
+ (setq uenv (cons elt uenv)))))))
+ (command
+ (when (stringp program)
+ (setenv-internal
+ env "INSIDE_EMACS"
+ (concat (or (getenv "INSIDE_EMACS") emacs-version)
+ ",tramp:" tramp-version)
+ 'keep)
+ (format "cd %s && %s exec %s %s env %s %s"
+ (tramp-shell-quote-argument localname)
+ (if uenv
+ (format
+ "unset %s &&"
+ (mapconcat
+ #'tramp-shell-quote-argument uenv " "))
+ "")
+ (if heredoc (format "<<'%s'" tramp-end-of-heredoc)
"")
+ (if tmpstderr (format "2>'%s'" tmpstderr) "")
+ (mapconcat #'tramp-shell-quote-argument env " ")
+ (if heredoc
+ (format "%s\n(\n%s\n) </dev/tty\n%s"
+ program (car args) tramp-end-of-heredoc)
+ (mapconcat #'tramp-shell-quote-argument
+ (cons program args) " ")))))
+ (tramp-process-connection-type
+ (or (null program) tramp-process-connection-type))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0)
+ ;; We do not want to raise an error when
+ ;; `make-process' has been started several times in
+ ;; `eshell' and friends.
+ tramp-current-connection
+ p)
+
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
+
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ ;; We catch this event. Otherwise, `make-process'
+ ;; could be called on the local host.
+ (save-excursion
+ (save-restriction
+ ;; Activate narrowing in order to save BUFFER
+ ;; contents. Clear also the modification time;
+ ;; otherwise we might be interrupted by
+ ;; `verify-visited-file-modtime'.
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t)
+ (mark (point-max)))
+ (clear-visited-file-modtime)
(narrow-to-region (point-max) (point-max))
- ;; Now do it.
- (if command
- ;; Send the command.
- (tramp-send-command v command nil t) ; nooutput
- ;; Check, whether a pty is associated.
- (unless (process-get p 'remote-tty)
- (tramp-error
- v 'file-error
- "pty association is not supported for `%s'"
- name))))
- ;; Set sentinel and filter.
- (when sentinel
- (set-process-sentinel p sentinel))
- (when filter
- (set-process-filter p filter))
- ;; Set query flag and process marker for this
- ;; process. We ignore errors, because the
- ;; process could have finished already.
- (ignore-errors
- (set-process-query-on-exit-flag p (null noquery))
- (set-marker (process-mark p) (point)))
- ;; We must flush them here already; otherwise
- ;; `rename-file', `delete-file' or
- ;; `insert-file-contents' will fail.
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer")
- ;; Copy tmpstderr file.
- (when (and (stringp stderr)
- (not (tramp-tramp-file-p stderr)))
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (rename-file remote-tmpstderr stderr))))
- ;; Provide error buffer. This shows only
- ;; initial error messages; messages arriving
- ;; later on will be inserted when the process is
- ;; deleted. The temporary file will exist until
- ;; the process is deleted.
- (when (bufferp stderr)
- (with-current-buffer stderr
- (insert-file-contents-literally remote-tmpstderr))
- ;; Delete tmpstderr file.
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (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)))
+ ;; We call `tramp-maybe-open-connection', in
+ ;; order to cleanup the prompt afterwards.
+ (catch 'suppress
+ (tramp-maybe-open-connection v)
+ (setq p (tramp-get-connection-process v))
+ ;; Set the pid of the remote shell. This is
+ ;; needed when sending signals remotely.
+ (let ((pid (tramp-send-command-and-read v "echo $$")))
+ (process-put p 'remote-pid pid)
+ (tramp-set-connection-property p "remote-pid" pid))
+ ;; `tramp-maybe-open-connection' and
+ ;; `tramp-send-command-and-read' could have
+ ;; trashed the connection buffer. Remove this.
+ (widen)
+ (delete-region mark (point-max))
+ (narrow-to-region (point-max) (point-max))
+ ;; Now do it.
+ (if command
+ ;; Send the command.
+ (tramp-send-command v command nil t) ; nooutput
+ ;; Check, whether a pty is associated.
+ (unless (process-get p 'remote-tty)
+ (tramp-error
+ v 'file-error
+ "pty association is not supported for `%s'"
+ name))))
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for this
+ ;; process. We ignore errors, because the
+ ;; process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; We must flush them here already; otherwise
+ ;; `rename-file', `delete-file' or
+ ;; `insert-file-contents' will fail.
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
+ ;; Copy tmpstderr file.
+ (when (and (stringp stderr)
+ (not (tramp-tramp-file-p stderr)))
+ (add-function
+ :after (process-sentinel p)
+ (lambda (_proc _msg)
+ (rename-file remote-tmpstderr stderr))))
+ ;; Provide error buffer. This shows only
+ ;; initial error messages; messages arriving
+ ;; later on will be inserted when the process
+ ;; is deleted. The temporary file will exist
+ ;; until the process is deleted.
+ (when (bufferp stderr)
+ (with-current-buffer stderr
+ (insert-file-contents-literally remote-tmpstderr))
+ ;; Delete tmpstderr file.
+ (add-function
+ :after (process-sentinel p)
+ (lambda (_proc _msg)
+ (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)))
- ;; Save exit.
- (if (string-match-p tramp-temp-buffer-name (buffer-name))
- (ignore-errors
- (set-process-buffer p nil)
- (kill-buffer (current-buffer)))
- (set-buffer-modified-p bmp))
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer"))))))))
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer p nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")))))))))
(defun tramp-sh-get-signal-strings (vec)
"Strings to return by `process-file' in case of signals."
@@ -3646,6 +3651,14 @@ Fall back to normal file name handler if no Tramp
handler exists."
(save-match-data (apply (cdr fn) args))
(tramp-run-real-handler operation args)))
+;;;###tramp-autoload
+(defun tramp-sh-file-name-handler-p (vec)
+ "Whether VEC uses a method from `tramp-sh-file-name-handler'."
+ (and (assoc (tramp-file-name-method vec) tramp-methods)
+ (eq (tramp-find-foreign-file-name-handler
+ (tramp-make-tramp-file-name vec nil 'nohop))
+ 'tramp-sh-file-name-handler)))
+
;; This must be the last entry, because `identity' always matches.
;;;###tramp-autoload
(tramp--with-startup
@@ -4769,6 +4782,12 @@ Goes through the list `tramp-inline-compress-commands'."
(tramp-message
vec 2 "Couldn't find an inline transfer compress command")))))
+;;;###tramp-autoload
+(defun tramp-multi-hop-p (vec)
+ "Whether the method of VEC is capable of multi-hops."
+ (and (tramp-sh-file-name-handler-p vec)
+ (not (tramp-get-method-parameter vec 'tramp-copy-program))))
+
(defun tramp-compute-multi-hops (vec)
"Expands VEC according to `tramp-default-proxies-alist'."
(let ((saved-tdpa tramp-default-proxies-alist)
@@ -4832,8 +4851,7 @@ Goes through the list `tramp-inline-compress-commands'."
(when (cdr target-alist)
(setq choices target-alist)
(while (setq item (pop choices))
- (when (or (not (tramp-get-method-parameter item 'tramp-login-program))
- (tramp-get-method-parameter item 'tramp-copy-program))
+ (unless (tramp-multi-hop-p item)
(setq tramp-default-proxies-alist saved-tdpa)
(tramp-user-error
vec "Method `%s' is not supported for multi-hops."
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index c169a86..fdf26f6 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1482,10 +1482,7 @@ default values are used."
(tramp-user-error
v "Method `%s' is not known." method))
;; Only some methods from tramp-sh.el do support multi-hops.
- (when (and
- hop
- (or (not (tramp-get-method-parameter v 'tramp-login-program))
- (tramp-get-method-parameter v 'tramp-copy-program)))
+ (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v))
(tramp-user-error
v "Method `%s' is not supported for multi-hops." method)))))))
@@ -1499,8 +1496,7 @@ See `tramp-dissect-file-name' for details."
tramp-postfix-host-format name))
nodefault)))
;; Only some methods from tramp-sh.el do support multi-hops.
- (when (or (not (tramp-get-method-parameter v 'tramp-login-program))
- (tramp-get-method-parameter v 'tramp-copy-program))
+ (unless (or nodefault non-essential (tramp-multi-hop-p v))
(tramp-user-error
v "Method `%s' is not supported for multi-hops."
(tramp-file-name-method v)))
@@ -3519,13 +3515,10 @@ User is always nil."
;; When we shall insert only a part of the file, we
;; copy this part. This works only for the shell file
- ;; name handlers.
+ ;; name handlers. It doesn't work for crypted files.
(when (and (or beg end)
- ;; Direct actions aren't possible for
- ;; crypted directories.
- (null tramp-crypt-enabled)
- (tramp-get-method-parameter
- v 'tramp-login-program))
+ (tramp-sh-file-name-handler-p v)
+ (null tramp-crypt-enabled))
(setq remote-copy (tramp-make-tramp-temp-file v))
;; This is defined in tramp-sh.el. Let's assume
;; this is loaded already.
@@ -3640,6 +3633,152 @@ User is always nil."
(load local-copy noerror t nosuffix must-suffix)
(delete-file local-copy)))))
t)))
+;; We use BUFFER also as connection buffer during setup. Because of
+;; this, its original contents must be saved, and restored once
+;; connection has been setup.
+(defun tramp-handle-make-process (&rest args)
+ "An alternative `make-process' implementation for Tramp files."
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'stringp stderr)))
+ (when (and (stringp stderr) (tramp-tramp-file-p stderr)
+ (not (tramp-equal-remote default-directory stderr)))
+ (signal 'file-error (list "Wrong stderr" stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ (command (append `("cd" ,localname "&&")
+ (mapcar #'tramp-shell-quote-argument command)))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0)
+ ;; We do not want to raise an error when `make-process'
+ ;; has been started several times in `eshell' and
+ ;; friends.
+ tramp-current-connection
+ p)
+
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
+
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ (let* ((login-program
+ (tramp-get-method-parameter v 'tramp-login-program))
+ (login-args
+ (tramp-get-method-parameter v 'tramp-login-args))
+ (async-args
+ (tramp-get-method-parameter v 'tramp-async-args))
+ ;; We don't create the temporary file. In
+ ;; fact, it is just a prefix for the
+ ;; ControlPath option of ssh; the real
+ ;; temporary file has another name, and it is
+ ;; created and protected by ssh. It is also
+ ;; removed by ssh when the connection is
+ ;; closed. The temporary file name is cached
+ ;; in the main connection process, therefore
+ ;; we cannot use `tramp-get-connection-process'.
+ (tmpfile
+ (when (tramp-sh-file-name-handler-p v)
+ (with-tramp-connection-property
+ (tramp-get-process v) "temp-file"
+ (tramp-compat-make-temp-name))))
+ (options
+ (when (tramp-sh-file-name-handler-p v)
+ (tramp-compat-funcall
+ 'tramp-ssh-controlmaster-options v)))
+ spec)
+
+ ;; Replace `login-args' place holders.
+ (setq
+ spec (format-spec-make ?t tmpfile)
+ options (format-spec (or options "") spec)
+ spec (format-spec-make
+ ?h (or host "") ?u (or user "") ?p (or port "")
+ ?c options ?l "")
+ ;; Add arguments for asynchronous processes.
+ login-args (append async-args login-args)
+ ;; Expand format spec.
+ login-args
+ (tramp-compat-flatten-tree
+ (mapcar
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) x))
+ login-args))
+ ;; Split ControlMaster options.
+ login-args
+ (tramp-compat-flatten-tree
+ (mapcar (lambda (x) (split-string x " ")) login-args))
+ p (apply
+ #'start-process
+ name buffer login-program (append login-args command)))
+
+ (tramp-message v 6 "%s" (string-join (process-command p) " "))
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for this
+ ;; process. We ignore errors, because the
+ ;; process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; We must flush them here already; otherwise
+ ;; `rename-file', `delete-file' or
+ ;; `insert-file-contents' will fail.
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
+ ;; Return process.
+ p)
+
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer p nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer"))))))))
(defun tramp-handle-make-symbolic-link
(target linkname &optional ok-if-already-exists)
@@ -3676,8 +3815,8 @@ support symbolic links."
(current-buffer))
(t (get-buffer-create
(if asynchronous
- "*Async Shell Command*"
- "*Shell Command Output*")))))
+ shell-command-buffer-name-async
+ shell-command-buffer-name)))))
(error-buffer
(cond
((bufferp error-buffer) error-buffer)
@@ -4706,7 +4845,7 @@ This handles also chrooted environments, which are not
regarded as local."
;; The method shall be applied to one of the shell file name
;; handlers. `tramp-local-host-p' is also called for "smb" and
;; alike, where it must fail.
- (tramp-get-method-parameter vec 'tramp-login-program)
+ (tramp-sh-file-name-handler-p vec)
;; Direct actions aren't possible for crypted directories.
(null tramp-crypt-enabled)
;; The local temp directory must be writable for the other user.
diff --git a/lisp/outline.el b/lisp/outline.el
index 28ea8a8..6158ed5 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -289,12 +289,19 @@ Turning on outline mode calls the value of
`text-mode-hook' and then of
(list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0)))
(add-hook 'change-major-mode-hook 'outline-show-all nil t))
+(defvar outline-minor-mode-map)
+
(defcustom outline-minor-mode-prefix "\C-c@"
"Prefix key to use for Outline commands in Outline minor mode.
The value of this variable is checked as part of loading Outline mode.
After that, changing the prefix key requires manipulating keymaps."
- :type 'string
- :group 'outlines)
+ :type 'key-sequence
+ :group 'outlines
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (define-key outline-minor-mode-map outline-minor-mode-prefix nil)
+ (define-key outline-minor-mode-map val outline-mode-prefix-map)
+ (set-default sym val)))
;;;###autoload
(define-minor-mode outline-minor-mode
diff --git a/lisp/play/snake.el b/lisp/play/snake.el
index d7c0683..70d80c4 100644
--- a/lisp/play/snake.el
+++ b/lisp/play/snake.el
@@ -192,6 +192,7 @@ and then start moving it leftwards.")
(defvar snake-null-map
(let ((map (make-sparse-keymap 'snake-null-map)))
(define-key map "n" 'snake-start-game)
+ (define-key map "q" 'quit-window)
map)
"Keymap for finished Snake games.")
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index cdbb59a..6122caf 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -3560,19 +3560,18 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
"\\(\\`\n?\\|^\n\\)=" ; POD
"\\|"
;; One extra () before this:
- "<<~?" ; HERE-DOC
- "\\(" ; 1 + 1
+ "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2
+ "\\(" ; 2 + 1
;; First variant "BLAH" or just ``.
"[ \t]*" ; Yes, whitespace is allowed!
- "\\([\"'`]\\)" ; 2 + 1 = 3
- "\\([^\"'`\n]*\\)" ; 3 + 1
- "\\3"
+ "\\([\"'`]\\)" ; 3 + 1 = 4
+ "\\([^\"'`\n]*\\)" ; 4 + 1
+ "\\4"
"\\|"
;; Second variant: Identifier or \ID (same as 'ID') or empty
- "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
+ "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1
;; Do not have <<= or << 30 or <<30 or << $blah.
;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
- "\\(\\)" ; To preserve count of pars :-( 6 + 1
"\\)"
"\\|"
;; 1+6 extra () before this:
@@ -3762,11 +3761,11 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
;; "\\(\\)" ; To preserve count of pars :-( 6 + 1
;; "\\)"
- ((match-beginning 2) ; 1 + 1
+ ((match-beginning 3) ; 2 + 1
(setq b (point)
tb (match-beginning 0)
c (and ; not HERE-DOC
- (match-beginning 5)
+ (match-beginning 6)
(save-match-data
(or (looking-at "[ \t]*(") ; << function_call()
(save-excursion ; 1 << func_name, or $foo << 10
@@ -3793,17 +3792,17 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(looking-at
"\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>")))
(error t)))))))
(error nil))) ; func(<<EOF)
- (and (not (match-beginning 6)) ; Empty
+ (and (not (match-beginning 7)) ; Empty
(looking-at
"[ \t]*[=0-9$@%&(]"))))))
(if c ; Not here-doc
nil ; Skip it.
- (setq c (match-end 2)) ; 1 + 1
- (if (match-beginning 5) ;4 + 1
- (setq b1 (match-beginning 5) ; 4 + 1
- e1 (match-end 5)) ; 4 + 1
- (setq b1 (match-beginning 4) ; 3 + 1
- e1 (match-end 4))) ; 3 + 1
+ (setq c (match-end 3)) ; 2 + 1
+ (if (match-beginning 6) ;6 + 1
+ (setq b1 (match-beginning 6) ; 5 + 1
+ e1 (match-end 6)) ; 5 + 1
+ (setq b1 (match-beginning 5) ; 4 + 1
+ e1 (match-end 5))) ; 4 + 1
(setq tag (buffer-substring b1 e1)
qtag (regexp-quote tag))
(cond (cperl-pod-here-fontify
@@ -3818,8 +3817,10 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(setq b (point))
;; We do not search to max, since we may be called from
;; some hook of fontification, and max is random
- (or (and (re-search-forward (concat "^[ \t]*" qtag "$")
- stop-point 'toend)
+ (or (and (re-search-forward
+ (concat "^" (when (equal (match-string 2) "~") "[
\t]*")
+ qtag "$")
+ stop-point 'toend)
;;;(eq (following-char) ?\n) ; XXXX WHY???
)
(progn ; Pretend we matched at the end
@@ -5752,7 +5753,7 @@ indentation and initial hashes. Behaves usually outside
of comment."
(if (eq (char-after (match-beginning 2)) ?%)
'cperl-hash-face
'cperl-array-face)
- t) ; arrays and hashes
+ nil) ; arrays and hashes
("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
1
(if (= (- (match-end 2) (match-beginning 2)) 1)
@@ -6499,9 +6500,10 @@ If optional argument ALL is `recursive', will process
Perl files
in subdirectories too."
(interactive)
(let ((cmd "etags")
- (args '("-l" "none" "-r"
+ (args `("-l" "none" "-r"
;; 1=fullname 2=package?
3=name 4=proto? 5=attrs? (VERY APPROX!)
- "/\\<" cperl-sub-regexp "[
\\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[
\t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/"
+ ,(concat
+ "/\\<" cperl-sub-regexp "[
\\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[
\t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/")
"-r"
"/\\<package[
\\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/"
"-r"
@@ -6786,6 +6788,7 @@ Use as
(or topdir
(setq topdir default-directory))
(let ((tags-file-name "TAGS")
+ (inhibit-read-only t)
(case-fold-search nil)
xs rel)
(save-excursion
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 51b9347..b616135 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1166,7 +1166,9 @@ 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)
- (setq project--list (assoc-delete-all dir project--list))
+ (dolist (ent project--list)
+ (when (equal dir (car ent))
+ (setq project--list (delq ent project--list))))
(push (list dir) project--list)
(project--write-project-list))))
@@ -1176,8 +1178,8 @@ If the directory was in the list before the removal, save
the
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))
+ (when-let ((ent (assoc pr-dir project--list)))
+ (setq project--list (delq ent project--list))
(message "Project `%s' not found; removed from list" pr-dir)
(project--write-project-list)))
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index 044d782..5a47594 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -838,7 +838,7 @@ See `sh-feature'.")
font-lock-variable-name-face))
(rc sh-append es)
- (bash sh-append sh ("\\$(\\(\\sw+\\)" (1 'sh-quoted-exec t) ))
+ (bash sh-append sh ("\\$(\\([^)\n]+\\)" (1 'sh-quoted-exec t) ))
(sh sh-append shell
;; Variable names.
("\\$\\({#?\\)?\\([[:alpha:]_][[:alnum:]_]*\\|[-#?@!]\\)" 2
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index c86fc59..a70b5ed 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -1508,6 +1508,22 @@ Based on `comint-mode-map'.")
table)
"Syntax table used in `sql-mode' and `sql-interactive-mode'.")
+;;; Syntax Properties
+
+;; `sql--syntax-propertize-escaped-apostrophe', as follows, was
+;; (analysed and) adapted from `pascal--syntax-propertize' in
+;; pascal.el because basic syntax parsing cannot handle the SQL ''
+;; construct within strings.
+
+(defconst sql--syntax-propertize-escaped-apostrophe
+ (syntax-propertize-rules
+ ("''"
+ (0
+ (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0))))
+ (string-to-syntax ".")
+ (forward-char -1)
+ nil)))))
+
;; Font lock support
(defvar sql-mode-font-lock-object-name
@@ -4210,6 +4226,10 @@ must tell Emacs. Here's how to do that in your init
file:
(setq-local abbrev-all-caps 1)
;; Contains the name of database objects
(set (make-local-variable 'sql-contains-names) t)
+ ;; Activate punctuation syntax table property for
+ ;; escaped apostrophes within strings:
+ (setq-local syntax-propertize-function
+ sql--syntax-propertize-escaped-apostrophe)
;; Set syntax and font-face highlighting
;; Catch changes to sql-product and highlight accordingly
(sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 27918a9..877edd4 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -1289,7 +1289,8 @@ Write data into the file specified by
`recentf-save-file'."
(insert "\n \n;; Local Variables:\n"
(format ";; coding: %s\n" recentf-save-file-coding-system)
";; End:\n")
- (write-file (expand-file-name recentf-save-file))
+ (write-region (point-min) (point-max)
+ (expand-file-name recentf-save-file))
(when recentf-save-file-modes
(set-file-modes recentf-save-file recentf-save-file-modes))
nil)
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 46738ab..d420bfb 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -1,4 +1,4 @@
-;;; saveplace.el --- automatically save place in files
+;;; saveplace.el --- automatically save place in files -*- lexical-binding:t
-*-
;; Copyright (C) 1993-1994, 2001-2020 Free Software Foundation, Inc.
@@ -42,7 +42,6 @@
"Automatically save place in files."
:group 'data)
-
(defvar save-place-alist nil
"Alist of saved places to go back to when revisiting files.
Each element looks like (FILENAME . POSITION);
@@ -175,10 +174,11 @@ file:
(declare-function dired-get-filename "dired" (&optional localp
no-error-if-not-filep))
(defun save-place-to-alist ()
- ;; put filename and point in a cons box and then cons that onto the
- ;; front of the save-place-alist, if save-place-mode is non-nil.
- ;; Otherwise, just delete that file from the alist.
- ;; first check to make sure alist has been loaded in from the master
+ "Add current buffer filename and position to `save-place-alist'.
+Put filename and point in a cons box and then cons that onto the
+front of the `save-place-alist', if `save-place-mode' is non-nil.
+Otherwise, just delete that file from the alist."
+ ;; First check to make sure alist has been loaded in from the master
;; file. If not, do so, then feel free to modify the alist. It
;; will be saved again when Emacs is killed.
(or save-place-loaded (load-save-place-alist-from-file))
diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el
index 3a6d9d3..f20ea1b 100644
--- a/lisp/scroll-lock.el
+++ b/lisp/scroll-lock.el
@@ -1,4 +1,4 @@
-;;; scroll-lock.el --- Scroll lock scrolling.
+;;; scroll-lock.el --- Scroll lock scrolling. -*- lexical-binding:t -*-
;; Copyright (C) 2005-2020 Free Software Foundation, Inc.
diff --git a/lisp/simple.el b/lisp/simple.el
index 2f92238..6c9584a 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3369,6 +3369,14 @@ which is defined in the `warnings' library.\n")
(setq buffer-undo-list nil)
t))
+;;;; Shell commands
+
+(defconst shell-command-buffer-name "*Shell Command Output*"
+ "Name of the output buffer for shell commands.")
+
+(defconst shell-command-buffer-name-async "*Async Shell Command*"
+ "Name of the output buffer for asynchronous shell commands.")
+
(defvar shell-command-history nil
"History list for some commands that read shell commands.
@@ -3433,7 +3441,7 @@ to `shell-command-history'."
(defcustom async-shell-command-buffer 'confirm-new-buffer
"What to do when the output buffer is used by another shell command.
This option specifies how to resolve the conflict where a new command
-wants to direct its output to the buffer `*Async Shell Command*',
+wants to direct its output to the buffer `shell-command-buffer-name-async',
but this buffer is already taken by another running shell command.
The value `confirm-kill-process' is used to ask for confirmation before
@@ -3585,14 +3593,14 @@ whose `car' is BUFFER."
Like `shell-command', but adds `&' at the end of COMMAND
to execute it asynchronously.
-The output appears in the buffer `*Async Shell Command*'.
+The output appears in the buffer `shell-command-buffer-name-async'.
That buffer is in shell mode.
You can configure `async-shell-command-buffer' to specify what to do
-when the `*Async Shell Command*' buffer is already taken by another
+when the `shell-command-buffer-name-async' buffer is already taken by another
running shell command. To run COMMAND without displaying the output
in a window you can configure `display-buffer-alist' to use the action
-`display-buffer-no-window' for the buffer `*Async Shell Command*'.
+`display-buffer-no-window' for the buffer `shell-command-buffer-name-async'.
In Elisp, you will often be better served by calling `start-process'
directly, since it offers more control and does not impose the use of
@@ -3628,12 +3636,12 @@ If `shell-command-prompt-show-cwd' is non-nil, show the
current
directory in the prompt.
If COMMAND ends in `&', execute it asynchronously.
-The output appears in the buffer `*Async Shell Command*'.
+The output appears in the buffer `shell-command-buffer-name-async'.
That buffer is in shell mode. You can also use
`async-shell-command' that automatically adds `&'.
Otherwise, COMMAND is executed synchronously. The output appears in
-the buffer `*Shell Command Output*'. If the output is short enough to
+the buffer `shell-command-buffer-name'. If the output is short enough to
display in the echo area (which is determined by the variables
`resize-mini-windows' and `max-mini-window-height'), it is shown
there, but it is nonetheless available in buffer `*Shell Command
@@ -3756,7 +3764,7 @@ impose the use of a shell (with its need to quote
arguments)."
(if (string-match "[ \t]*&[ \t]*\\'" command)
;; Command ending with ampersand means asynchronous.
(let* ((buffer (get-buffer-create
- (or output-buffer "*Async Shell Command*")))
+ (or output-buffer
shell-command-buffer-name-async)))
(bname (buffer-name buffer))
(proc (get-buffer-process buffer))
(directory default-directory))
@@ -3908,7 +3916,7 @@ and are used only if a pop-up buffer is displayed."
error-buffer display-error-buffer
region-noncontiguous-p)
"Execute string COMMAND in inferior shell with region as input.
-Normally display output (if any) in temp buffer `*Shell Command Output*';
+Normally display output (if any) in temp buffer `shell-command-buffer-name';
Prefix arg means replace the region with it. Return the exit code of
COMMAND.
@@ -3927,7 +3935,7 @@ in the echo area or in a buffer.
If the output is short enough to display in the echo area
\(determined by the variable `max-mini-window-height' if
`resize-mini-windows' is non-nil), it is shown there.
-Otherwise it is displayed in the buffer `*Shell Command Output*'.
+Otherwise it is displayed in the buffer `shell-command-buffer-name'.
The output is available in that buffer in both cases.
If there is output and an error, a message about the error
@@ -3937,7 +3945,7 @@ Optional fourth arg OUTPUT-BUFFER specifies where to put
the
command's output. If the value is a buffer or buffer name,
erase that buffer and insert the output there; a non-nil value of
`shell-command-dont-erase-buffer' prevent to erase the buffer.
-If the value is nil, use the buffer `*Shell Command Output*'.
+If the value is nil, use the buffer `shell-command-buffer-name'.
Any other non-nil value means to insert the output in the
current buffer after START.
@@ -4006,7 +4014,7 @@ characters."
(funcall region-insert-function output))
(t
(let ((buffer (get-buffer-create
- (or output-buffer "*Shell Command Output*"))))
+ (or output-buffer shell-command-buffer-name))))
(with-current-buffer buffer
(erase-buffer)
(funcall region-insert-function output))
@@ -4025,7 +4033,7 @@ characters."
(list t error-file)
t)))
;; It is rude to delete a buffer that the command is not using.
- ;; (let ((shell-buffer (get-buffer "*Shell Command Output*")))
+ ;; (let ((shell-buffer (get-buffer shell-command-buffer-name)))
;; (and shell-buffer (not (eq shell-buffer (current-buffer)))
;; (kill-buffer shell-buffer)))
;; Don't muck with mark unless REPLACE says we should.
@@ -4033,12 +4041,13 @@ characters."
;; No prefix argument: put the output in a temp buffer,
;; replacing its entire contents.
(let ((buffer (get-buffer-create
- (or output-buffer "*Shell Command Output*"))))
+ (or output-buffer shell-command-buffer-name))))
(set-buffer-major-mode buffer) ; Enable globalized modes (bug#38111)
(unwind-protect
(if (and (eq buffer (current-buffer))
(or (memq shell-command-dont-erase-buffer '(nil erase))
- (and (not (eq buffer (get-buffer "*Shell Command
Output*")))
+ (and (not (eq buffer (get-buffer
+ shell-command-buffer-name)))
(not (region-active-p)))))
;; If the input is the same buffer as the output,
;; delete everything but the specified region,
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index 8c694c1..ea4e5db 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -1,4 +1,4 @@
-;;; skeleton.el --- Lisp language extension for writing statement skeletons
+;;; skeleton.el --- Lisp language extension for writing statement skeletons
-*- lexical-binding: t; -*-
;; Copyright (C) 1993-1996, 2001-2020 Free Software Foundation, Inc.
@@ -135,7 +135,8 @@ A prefix argument of -1 says to wrap around region, even if
not highlighted.
A prefix argument of zero says to wrap around zero words---that is, nothing.
This is a way of overriding the use of a highlighted region.")
(interactive "*P\nP")
- (skeleton-proxy-new ',skeleton str arg))))
+ (atomic-change-group
+ (skeleton-proxy-new ',skeleton str arg)))))
;;;###autoload
(defun skeleton-proxy-new (skeleton &optional str arg)
@@ -154,8 +155,7 @@ of `str' whereas the skeleton's interactor is then ignored."
(prefix-numeric-value (or arg
current-prefix-arg))
(and skeleton-autowrap
- (or (eq last-command 'mouse-drag-region)
- (and transient-mark-mode mark-active))
+ (use-region-p)
;; Deactivate the mark, in case one of the
;; elements of the skeleton is sensitive
;; to such situations (e.g. it is itself a
@@ -258,23 +258,25 @@ available:
(goto-char (car skeleton-regions))
(setq skeleton-regions (cdr skeleton-regions)))
(let ((beg (point))
- skeleton-modified skeleton-point resume: help input v1 v2)
- (setq skeleton-positions nil)
- (unwind-protect
- (cl-progv
- (mapcar #'car skeleton-further-elements)
- (mapcar (lambda (x) (eval (cadr x))) skeleton-further-elements)
- (skeleton-internal-list skeleton str))
- (or (eolp) (not skeleton-end-newline) (newline-and-indent))
- (run-hooks 'skeleton-end-hook)
- (sit-for 0)
- (or (not (eq (window-buffer) (current-buffer)))
- (pos-visible-in-window-p beg)
- (progn
- (goto-char beg)
- (recenter 0)))
- (if skeleton-point
- (goto-char skeleton-point))))))
+ skeleton-modified skeleton-point) ;; resume:
+ (with-suppressed-warnings ((lexical help input v1 v2))
+ (dlet (help input v1 v2)
+ (setq skeleton-positions nil)
+ (unwind-protect
+ (cl-progv
+ (mapcar #'car skeleton-further-elements)
+ (mapcar (lambda (x) (eval (cadr x) t))
skeleton-further-elements)
+ (skeleton-internal-list skeleton str))
+ (or (eolp) (not skeleton-end-newline) (newline-and-indent))
+ (run-hooks 'skeleton-end-hook)
+ (sit-for 0)
+ (or (not (eq (window-buffer) (current-buffer)))
+ (pos-visible-in-window-p beg)
+ (progn
+ (goto-char beg)
+ (recenter 0)))
+ (if skeleton-point
+ (goto-char skeleton-point))))))))
(defun skeleton-read (prompt &optional initial-input recursive)
"Function for reading a string from the minibuffer within skeletons.
@@ -327,36 +329,39 @@ automatically, and you are prompted to fill in the
variable parts.")))
(signal 'quit t)
prompt))
-(defun skeleton-internal-list (skeleton-il &optional str recursive)
+(defun skeleton-internal-list (skeleton &optional str recursive)
(let* ((start (line-beginning-position))
(column (current-column))
(line (buffer-substring start (line-end-position)))
- opoint)
- (or str
- (setq str `(setq str
- (skeleton-read ',(car skeleton-il) nil ,recursive))))
- (when (and (eq (cadr skeleton-il) '\n) (not recursive)
- (save-excursion (skip-chars-backward " \t") (bolp)))
- (setq skeleton-il (cons nil (cons '> (cddr skeleton-il)))))
- (while (setq skeleton-modified (eq opoint (point))
- opoint (point)
- skeleton-il (cdr skeleton-il))
- (condition-case quit
- (skeleton-internal-1 (car skeleton-il) nil recursive)
- (quit
- (if (eq (cdr quit) 'recursive)
- (setq recursive 'quit
- skeleton-il (memq 'resume: skeleton-il))
- ;; Remove the subskeleton as far as it has been shown
- ;; the subskeleton shouldn't have deleted outside current line.
- (end-of-line)
- (delete-region start (point))
- (insert line)
- (move-to-column column)
- (if (cdr quit)
- (setq skeleton-il ()
- recursive nil)
- (signal 'quit 'recursive)))))))
+ (skeleton-il skeleton)
+ opoint)
+ (with-suppressed-warnings ((lexical str))
+ (dlet ((str (or str
+ `(setq str
+ (skeleton-read ',(car skeleton-il)
+ nil ,recursive)))))
+ (when (and (eq (cadr skeleton-il) '\n) (not recursive)
+ (save-excursion (skip-chars-backward " \t") (bolp)))
+ (setq skeleton-il (cons nil (cons '> (cddr skeleton-il)))))
+ (while (setq skeleton-modified (eq opoint (point))
+ opoint (point)
+ skeleton-il (cdr skeleton-il))
+ (condition-case quit
+ (skeleton-internal-1 (car skeleton-il) nil recursive)
+ (quit
+ (if (eq (cdr quit) 'recursive)
+ (setq recursive 'quit
+ skeleton-il (memq 'resume: skeleton-il))
+ ;; Remove the subskeleton as far as it has been shown
+ ;; the subskeleton shouldn't have deleted outside current line.
+ (end-of-line)
+ (delete-region start (point))
+ (insert line)
+ (move-to-column column)
+ (if (cdr quit)
+ (setq skeleton-il ()
+ recursive nil)
+ (signal 'quit 'recursive)))))))))
;; maybe continue loop or go on to next outer resume: section
(if (eq recursive 'quit)
(signal 'quit 'recursive)
diff --git a/lisp/so-long.el b/lisp/so-long.el
index 6b05f48..f2c078b 100644
--- a/lisp/so-long.el
+++ b/lisp/so-long.el
@@ -38,7 +38,7 @@
;; compacted into the smallest file size possible, which often entails removing
;; newlines should they not be strictly necessary). This can result in lines
;; which are many thousands of characters long, and most programming modes
-;; simply aren't optimized (remotely) for this scenario, so performance can
+;; simply aren't optimised (remotely) for this scenario, so performance can
;; suffer significantly.
;;
;; When such files are detected, the command `so-long' is automatically called,
@@ -69,7 +69,7 @@
;; the long lines. In such circumstances you may find that `longlines-mode' is
;; the most helpful facility.
;;
-;; Note also that the mitigation is automatically triggered when visiting a
+;; Note also that the mitigations are automatically triggered when visiting a
;; file. The library does not automatically detect if long lines are inserted
;; into an existing buffer (although the `so-long' command can be invoked
;; manually in such situations).
@@ -90,7 +90,7 @@
;; * Overview of modes and commands
;; --------------------------------
;; - `global-so-long-mode' - A global minor mode which enables the automated
-;; behavior, causing the user's preferred action to be invoked whenever a
+;; behaviour, causing the user's preferred action to be invoked whenever a
;; newly-visited file contains excessively long lines.
;; - `so-long-mode' - A major mode, and the default action.
;; - `so-long-minor-mode' - A minor mode version of the major mode, and an
@@ -111,7 +111,7 @@
;;
;; On rare occasions you may choose to manually invoke the `so-long' command,
;; which invokes your preferred `so-long-action' (exactly as the automatic
-;; behavior would do if it had detected long lines). You might use this if a
+;; behaviour would do if it had detected long lines). You might use this if a
;; problematic file did not meet your configured criteria, and you wished to
;; trigger the performance improvements manually.
;;
@@ -120,7 +120,7 @@
;; available to `so-long' but, like any other mode, they can be invoked
directly
;; if you have a need to do that (see also "Other ways of using so-long"
below).
;;
-;; If the behavior ever triggers when you did not want it to, you can use the
+;; If the behaviour ever triggers when you did not want it to, you can use the
;; `so-long-revert' command to restore the buffer to its original state.
;; * Basic configuration
@@ -199,7 +199,7 @@
;;
;; Note that `so-long-minor-modes' is not useful for other global minor modes
;; (as distinguished from globalized minor modes), but in some cases it will be
-;; possible to inhibit or otherwise counter-act the behavior of a global mode
+;; possible to inhibit or otherwise counter-act the behaviour of a global mode
;; by overriding variables, or by employing hooks (see below). You would need
;; to inspect the code for a given global mode (on a case by case basis) to
;; determine whether it's possible to inhibit it for a single buffer -- and if
@@ -211,7 +211,7 @@
;; If `so-long-action' is set to either `so-long-mode' or `so-long-minor-mode',
;; the buffer-local value for each variable in the list is set to the
associated
;; value in the alist. Use this to enforce values which will improve
-;; performance or otherwise avoid undesirable behaviors. If `so-long-revert'
+;; performance or otherwise avoid undesirable behaviours. If `so-long-revert'
;; is called, then the original values are restored.
;; * Hooks
@@ -325,7 +325,7 @@
;; meaning you would need to add to `safe-local-variable-values' in order to
;; avoid being queried about them.
;;
-;; Finally, the `so-long-predicate' user option enables the automated behavior
+;; Finally, the `so-long-predicate' user option enables the automated behaviour
;; to be determined by a custom function, if greater control is needed.
;; * Implementation notes
@@ -342,7 +342,7 @@
;; * Caveats
;; ---------
-;; The variables affecting the automated behavior of this library (such as
+;; The variables affecting the automated behaviour of this library (such as
;; `so-long-action') can be used as file- or dir-local values in Emacs 26+, but
;; not in previous versions of Emacs. This is on account of improvements made
;; to `normal-mode' in 26.1, which altered the execution order with respect to
@@ -386,7 +386,7 @@
;; - Added sgml-mode and nxml-mode to `so-long-target-modes'.
;; 0.7.4 - Refactored the handling of `whitespace-mode'.
;; 0.7.3 - Added customize group `so-long' with user options.
-;; - Added `so-long-original-values' to generalize the storage and
+;; - Added `so-long-original-values' to generalise the storage and
;; restoration of values from the original mode upon `so-long-revert'.
;; - Added `so-long-revert-hook'.
;; 0.7.2 - Remember the original major mode even with M-x `so-long-mode'.
@@ -399,7 +399,7 @@
;; 0.6 - Added `so-long-minor-modes' and `so-long-hook'.
;; 0.5 - Renamed library to "so-long.el".
;; - Added explicit `so-long-enable' command to activate our advice.
-;; 0.4 - Amended/documented behavior with file-local 'mode' variables.
+;; 0.4 - Amended/documented behaviour with file-local 'mode' variables.
;; 0.3 - Defer to a file-local 'mode' variable.
;; 0.2 - Initial release to EmacsWiki.
;; 0.1 - Experimental.
@@ -421,7 +421,7 @@
Has no effect if `global-so-long-mode' is not enabled.")
(defvar-local so-long--active nil ; internal use
- "Non-nil when `so-long' mitigation is in effect.")
+ "Non-nil when `so-long' mitigations are in effect.")
(defvar so-long--set-auto-mode nil ; internal use
"Non-nil while `set-auto-mode' is executing.")
@@ -500,7 +500,7 @@ files would prevent Emacs from handling them correctly."
(defcustom so-long-invisible-buffer-function #'so-long-deferred
"Function called in place of `so-long' when the buffer is not displayed.
-This affects the behavior of `global-so-long-mode'.
+This affects the behaviour of `global-so-long-mode'.
We treat invisible buffers differently from displayed buffers because, in
cases where a library is using a buffer for behind-the-scenes processing,
@@ -548,7 +548,7 @@ Defaults to `so-long-detected-long-line-p'."
(defun so-long--action-type ()
"Generate a :type for `so-long-action' based on `so-long-action-alist'."
;; :type seemingly cannot be a form to be evaluated on demand, so we
- ;; endeavor to keep it up-to-date with `so-long-action-alist' by
+ ;; endeavour to keep it up-to-date with `so-long-action-alist' by
;; calling this from `so-long--action-alist-setter'.
`(radio ,@(mapcar (lambda (x) (list 'const :tag (cadr x) (car x)))
(assq-delete-all nil so-long-action-alist))
@@ -609,7 +609,7 @@ will be automatically processed; but custom actions can
also do these things.
The value `longlines-mode' causes that minor mode to be enabled. See
longlines.el for more details.
-Each action likewise determines the behavior of `so-long-revert'.
+Each action likewise determines the behaviour of `so-long-revert'.
If the value is nil, or not defined in `so-long-action-alist', then no action
will be taken."
@@ -740,7 +740,7 @@ was established."
)
;; It's not clear to me whether all of these would be problematic, but they
;; seemed like reasonable targets. Some are certainly excessive in smaller
- ;; buffers of minified code, but we should be aiming to maximize performance
+ ;; buffers of minified code, but we should be aiming to maximise performance
;; by default, so that Emacs is as responsive as we can manage in even very
;; large buffers of minified code.
"List of buffer-local minor modes to explicitly disable.
@@ -756,7 +756,7 @@ By default this happens if `so-long-action' is set to
either `so-long-mode'
or `so-long-minor-mode'. If `so-long-revert' is subsequently invoked, then the
disabled modes are re-enabled by calling them with the numeric argument 1.
-`so-long-hook' can be used where more custom behavior is desired.
+`so-long-hook' can be used where more custom behaviour is desired.
Please submit bug reports to recommend additional modes for this list, whether
they are in Emacs core, GNU ELPA, or elsewhere."
@@ -781,9 +781,20 @@ If `so-long-revert' is subsequently invoked, then the
variables are restored
to their original states.
The combination of `line-move-visual' (enabled) and `truncate-lines' (disabled)
-is important for maximizing responsiveness when moving vertically within an
+is important for maximising responsiveness when moving vertically within an
extremely long line, as otherwise the full length of the line may need to be
-scanned to find the next position."
+scanned to find the next position.
+
+Bidirectional text display -- especially handling the large quantities of
+nested parentheses which are liable to occur in minified programming code --
+can be very expensive for extremely long lines, and so this support is disabled
+by default (insofar as is supported; in particular `bidi-inhibit-bpa' is not
+available in Emacs versions < 27). For more information refer to info node
+`(emacs) Bidirectional Editing' and info node `(elisp) Bidirectional Display'.
+
+Buffers are made read-only by default to prevent potentially-slow editing from
+occurring inadvertantly, as buffers with excessively long lines are likely not
+intended to be edited manually."
:type '(alist :key-type (variable :tag "Variable")
:value-type (sexp :tag "Value"))
:options '((bidi-inhibit-bpa boolean)
@@ -822,18 +833,18 @@ If nil, no mode line indicator will be displayed."
(defface so-long-mode-line-active
'((t :inherit mode-line-emphasis))
- "Face for `so-long-mode-line-info' when mitigation is active."
+ "Face for `so-long-mode-line-info' when mitigations are active."
:package-version '(so-long . "1.0"))
(defface so-long-mode-line-inactive
'((t :inherit mode-line-inactive))
- "Face for `so-long-mode-line-info' when mitigation has been reverted."
+ "Face for `so-long-mode-line-info' when mitigations have been reverted."
:package-version '(so-long . "1.0"))
;; Modes that go slowly and line lengths excessive
;; Font-lock performance becoming oppressive
;; All of my CPU tied up with strings
-;; These are a few of my least-favorite things
+;; These are a few of my least-favourite things
(defvar-local so-long-original-values nil
"Alist holding the buffer's original `major-mode' value, and other data.
@@ -985,7 +996,7 @@ Displayed as part of `mode-line-misc-info'.
`so-long-mode-line-label' defines the text to be displayed (if any).
-Face `so-long-mode-line-active' is used while mitigation is active, and
+Face `so-long-mode-line-active' is used while mitigations are active, and
`so-long-mode-line-inactive' is used if `so-long-revert' is called.
Not displayed when `so-long-mode' is enabled, as the major mode construct
@@ -1038,7 +1049,9 @@ This is the default value of `so-long-predicate'."
(let ((count 0) start)
(save-excursion
(goto-char (point-min))
- (when so-long-skip-leading-comments
+ (when (and so-long-skip-leading-comments
+ (or comment-use-syntax ;; Refer to `comment-forward'.
+ (and comment-start-skip comment-end-skip)))
;; Skip the shebang line, if any. This is not necessarily comment
;; syntax, so we need to treat it specially.
(when (looking-at "#!")
@@ -1131,7 +1144,7 @@ This minor mode is a standard `so-long-action' option."
(if so-long-minor-mode ;; We are enabling the mode.
(progn
;; Housekeeping. `so-long-minor-mode' might be invoked directly rather
- ;; than via `so-long', so replicate the necessary behaviors. The minor
+ ;; than via `so-long', so replicate the necessary behaviours. The
minor
;; mode also cares about whether `so-long' was already active, as we do
;; not want to remember values which were potentially overridden
already.
(unless (or so-long--calling so-long--active)
@@ -1203,9 +1216,9 @@ values), despite potential performance issues, type
\\[so-long-revert].
Use \\[so-long-commentary] for more information.
-Use \\[so-long-customize] to configure the behavior."
+Use \\[so-long-customize] to configure the behaviour."
;; Housekeeping. `so-long-mode' might be invoked directly rather than via
- ;; `so-long', so replicate the necessary behaviors. We could use this same
+ ;; `so-long', so replicate the necessary behaviours. We could use this same
;; test in `so-long-after-change-major-mode' to run `so-long-hook', but
that's
;; not so obviously the right thing to do, so I've omitted it for now.
(unless so-long--calling
@@ -1251,7 +1264,7 @@ Use \\[so-long-customize] to configure the behavior."
This advice acts before `so-long-mode', with the previous mode still active."
(unless (derived-mode-p 'so-long-mode)
;; Housekeeping. `so-long-mode' might be invoked directly rather than
- ;; via `so-long', so replicate the necessary behaviors.
+ ;; via `so-long', so replicate the necessary behaviours.
(unless so-long--calling
(so-long-remember-all :reset))
;; Remember the original major mode, regardless.
@@ -1336,7 +1349,7 @@ This is the `so-long-revert-function' for `so-long-mode'."
;; Emacs 26+ has already called `hack-local-variables' (during
;; `run-mode-hooks'; provided there was a `buffer-file-name'), but for
older
;; versions we need to call it here. In Emacs 26+ the revised
'HANDLE-MODE'
- ;; argument is set to `no-mode' (being the non-nil-and-non-t behavior),
+ ;; argument is set to `no-mode' (being the non-nil-and-non-t behaviour),
;; which we mimic here by binding `so-long--hack-local-variables-no-mode',
;; in order to prevent a local 'mode' variable from clobbering the major
;; mode we have just called.
@@ -1373,7 +1386,7 @@ because we do not want to downgrade the major mode in
that scenario."
;; Act only if `so-long-mode' would be enabled by the current action.
(when (and (symbolp (so-long-function))
(provided-mode-derived-p (so-long-function) 'so-long-mode))
- ;; Downgrade from `so-long-mode' to the `so-long-minor-mode' behavior.
+ ;; Downgrade from `so-long-mode' to the `so-long-minor-mode' behaviour.
(setq so-long-function 'turn-on-so-long-minor-mode
so-long-revert-function 'turn-off-so-long-minor-mode))))
@@ -1393,7 +1406,7 @@ and cannot be conveniently intercepted, so we are forced
to replicate it here.
This special-case code will ultimately be removed from Emacs, as it exists to
deal with a deprecated feature; but until then we need to replicate it in order
-to inhibit our own behavior in the presence of a header comment `mode'
+to inhibit our own behaviour in the presence of a header comment `mode'
declaration.
If a file-local mode is detected in the header comment, then we call the
@@ -1528,7 +1541,7 @@ by testing the value against `major-mode'; but as we may
have changed the
major mode to `so-long-mode' by this point, that protection is insufficient
and so we need to perform our own test.
-We likewise need to support an equivalent of the `no-mode' behavior in 26.1+
+We likewise need to support an equivalent of the `no-mode' behaviour in 26.1+
to ensure that `so-long-mode-revert' will not restore a file-local mode again
after it has already reverted to the original mode.
@@ -1661,7 +1674,7 @@ Equivalent to calling (global-so-long-mode 0)"
;;;###autoload
(define-minor-mode global-so-long-mode
- "Toggle automated performance mitigation for files with long lines.
+ "Toggle automated performance mitigations for files with long lines.
Many Emacs modes struggle with buffers which contain excessively long lines,
and may consequently cause unacceptable performance issues.
@@ -1675,7 +1688,7 @@ When such files are detected by `so-long-predicate', we
invoke the selected
Use \\[so-long-commentary] for more information.
-Use \\[so-long-customize] to configure the behavior."
+Use \\[so-long-customize] to configure the behaviour."
:global t
:group 'so-long
(if global-so-long-mode
@@ -1810,9 +1823,10 @@ If it appears in `%s', you should remove it."
;; Update to version 1.0 from earlier versions:
(when (version< so-long-version "1.0")
(remove-hook 'change-major-mode-hook 'so-long-change-major-mode)
- (require 'advice)
+ (eval-and-compile (require 'advice)) ;; Both macros and functions.
(declare-function ad-find-advice "advice")
(declare-function ad-remove-advice "advice")
+ (declare-function ad-activate "advice")
(when (ad-find-advice 'hack-local-variables 'after
'so-long--file-local-mode)
(ad-remove-advice 'hack-local-variables 'after 'so-long--file-local-mode)
(ad-activate 'hack-local-variables))
@@ -1864,8 +1878,8 @@ If it appears in `%s', you should remove it."
; LocalWords: noerror selectable mapc sgml nxml hl flydiff defs arg Phil
Sainty
; LocalWords: defadvice nadvice whitespace ie bos eos eobp origmode un Un setq
; LocalWords: docstring auf Wiedersehen longlines alist autoload Refactored
Inc
-; LocalWords: MERCHANTABILITY RET REGEXP VAR ELPA WS EmacsWiki eval
-; LocalWords: rx filename filenames
+; LocalWords: MERCHANTABILITY RET REGEXP VAR ELPA WS mitigations EmacsWiki
eval
+; LocalWords: rx filename filenames bidi bpa
;; So long, farewell, auf Wiedersehen, goodbye
;; You have to go, this code is minified
diff --git a/lisp/subr.el b/lisp/subr.el
index 2ef28b1..0ae636b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -888,6 +888,10 @@ side-effects, and the argument LIST is not modified."
;;;; Keymap support.
+;; Declare before first use of `save-match-data',
+;; where it is used internally.
+(defvar save-match-data-internal)
+
(defun kbd (keys)
"Convert KEYS to the internal Emacs key representation.
KEYS should be a string in the format returned by commands such
@@ -4110,8 +4114,6 @@ MODES is as for `set-default-file-modes'."
;;; Matching and match data.
-(defvar save-match-data-internal)
-
;; We use save-match-data-internal as the local variable because
;; that works ok in practice (people should not use that variable elsewhere).
;; We used to use an uninterned symbol; the compiler handles that properly
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index 73978ff..5cf09f9 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -922,6 +922,56 @@ actually appear on disk when you save the tar-file's
buffer."
(setq buffer-undo-list nil))))
buffer))
+(defun tar-goto-file (file)
+ "Go to FILE in the current buffer.
+FILE should be a relative file name. If FILE can't be found,
+return nil. Otherwise point is returned."
+ (let ((start (point))
+ found)
+ (goto-char (point-min))
+ (while (and (not found)
+ (not (eobp)))
+ (forward-line 1)
+ (when-let ((descriptor (ignore-errors (tar-get-descriptor))))
+ (when (equal (tar-header-name descriptor) file)
+ (setq found t))))
+ (if (not found)
+ (progn
+ (goto-char start)
+ nil)
+ (point))))
+
+(defun tar-next-file-displayer (file regexp n)
+ "Return a closure to display the next file after FILE that matches REGEXP."
+ (let ((short (replace-regexp-in-string "\\`.*!" "" file))
+ next)
+ ;; The tar buffer chops off leading "./", so do the same
+ ;; here.
+ (setq short (replace-regexp-in-string "\\`\\./" "" file))
+ (tar-goto-file short)
+ (while (and (not next)
+ ;; Stop if we reach the end/start of the buffer.
+ (if (> n 0)
+ (not (eobp))
+ (not (save-excursion
+ (beginning-of-line)
+ (bobp)))))
+ (tar-next-line n)
+ (when-let ((descriptor (ignore-errors (tar-get-descriptor))))
+ (let ((candidate (tar-header-name descriptor))
+ (buffer (current-buffer)))
+ (when (and candidate
+ (string-match-p regexp candidate))
+ (setq next (lambda ()
+ (kill-buffer (current-buffer))
+ (switch-to-buffer buffer)
+ (tar-extract)))))))
+ (unless next
+ ;; If we didn't find a next/prev file, then restore
+ ;; point.
+ (tar-goto-file short))
+ next))
+
(defun tar-extract (&optional other-window-p)
"In Tar mode, extract this entry of the tar file into its own buffer."
(interactive)
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 2cd9978..cc58798 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -67,7 +67,7 @@
(defconst scss-at-ids
'("at-root" "content" "debug" "each" "else" "else if" "error" "extend"
- "for" "function" "if" "import" "include" "mixin" "return" "warn"
+ "for" "function" "if" "import" "include" "mixin" "return" "use" "warn"
"while")
"Additional identifiers that appear in the form @foo in SCSS.")
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index b5ff6a6..1672dce 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -1806,6 +1806,7 @@ This takes effect when first loading the library.")
(define-key map "\C-c\C-cc" 'html-checkboxes)
(define-key map "\C-c\C-cl" 'html-list-item)
(define-key map "\C-c\C-ch" 'html-href-anchor)
+ (define-key map "\C-c\C-cf" 'html-href-anchor-file)
(define-key map "\C-c\C-cn" 'html-name-anchor)
(define-key map "\C-c\C-c#" 'html-id-anchor)
(define-key map "\C-c\C-ci" 'html-image)
@@ -1818,6 +1819,7 @@ This takes effect when first loading the library.")
(define-key map "\C-cc" 'html-checkboxes)
(define-key map "\C-cl" 'html-list-item)
(define-key map "\C-ch" 'html-href-anchor)
+ (define-key map "\C-cf" 'html-href-anchor-file)
(define-key map "\C-cn" 'html-name-anchor)
(define-key map "\C-c#" 'html-id-anchor)
(define-key map "\C-ci" 'html-image)
@@ -1845,7 +1847,8 @@ This takes effect when first loading the library.")
(define-key menu-map "\n" '("Line Break" . html-line))
(define-key menu-map "\r" '("Paragraph" . html-paragraph))
(define-key menu-map "i" '("Image" . html-image))
- (define-key menu-map "h" '("Href Anchor" . html-href-anchor))
+ (define-key menu-map "h" '("Href Anchor URL" . html-href-anchor))
+ (define-key menu-map "f" '("Href Anchor File" . html-href-anchor-file))
(define-key menu-map "n" '("Name Anchor" . html-name-anchor))
(define-key menu-map "#" '("ID Anchor" . html-id-anchor))
map)
@@ -2453,6 +2456,11 @@ HTML Autoview mode is a buffer-local minor mode for use
with
;; '(setq input "http:")
"<a href=\"" str "\">" _ "</a>")
+(define-skeleton html-href-anchor-file
+ "HTML anchor tag with href attribute (from a local file)."
+ (file-relative-name (read-file-name "File name: ") default-directory)
+ "<a href=\"" str "\">" _ "</a>")
+
(define-skeleton html-name-anchor
"HTML anchor tag with name attribute."
"Name: "
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 1a15df3..483a2c9 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -334,7 +334,7 @@ the bounds of a possible ill-formed URI (one lacking a
scheme)."
;; may contain parentheses but may not contain spaces (RFC3986).
(let* ((allowed-chars "--:=&?$+@-Z_[:alpha:]~#,%;*()!'")
(skip-before "^[0-9a-zA-Z]")
- (skip-after ":;.,!?")
+ (skip-after ":;.,!?'")
(pt (point))
(beg (save-excursion
(skip-chars-backward allowed-chars)
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index 95ced7b..cb0657e 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -186,6 +186,16 @@ highlighting the Log View buffer."
:group 'vc-hg
:version "24.5")
+(defcustom vc-hg-create-bookmark t
+ "This controls whether `vc-create-tag' will create a bookmark or branch.
+If nil, named branch will be created.
+If t, bookmark will be created.
+If `ask', you will be prompted for a branch type."
+ :type '(choice (const :tag "No" nil)
+ (const :tag "Yes" t)
+ (const :tag "Ask" ask))
+ :version "28.1")
+
;; Clear up the cache to force vc-call to check again and discover
;; new functions when we reload this file.
@@ -625,10 +635,18 @@ Optional arg REVISION is a revision to annotate from."
;;; Tag system
(defun vc-hg-create-tag (dir name branchp)
- "Attach the tag NAME to the state of the working copy."
+ "Create tag NAME in repo in DIR. Create branch if BRANCHP.
+Variable `vc-hg-create-bookmark' controls what kind of branch will be created."
(let ((default-directory dir))
- (and (vc-hg-command nil 0 nil "status")
- (vc-hg-command nil 0 nil (if branchp "bookmark" "tag") name))))
+ (vc-hg-command nil 0 nil
+ (if branchp
+ (if (if (eq vc-hg-create-bookmark 'ask)
+ (yes-or-no-p "Create bookmark instead of
branch? ")
+ vc-hg-create-bookmark)
+ "bookmark"
+ "branch")
+ "tag")
+ name)))
(defun vc-hg-retrieve-tag (dir name _update)
"Retrieve the version tagged by NAME of all registered files at or below
DIR."
@@ -1366,25 +1384,28 @@ REV is the revision to check out into WORKFILE."
(vc-run-delayed
(vc-hg-after-dir-status update-function)))
-(defun vc-hg-dir-extra-header (name &rest commands)
- (concat (propertize name 'face 'font-lock-type-face)
- (propertize
- (with-temp-buffer
- (apply 'vc-hg-command (current-buffer) 0 nil commands)
- (buffer-substring-no-properties (point-min) (1- (point-max))))
- 'face 'font-lock-variable-name-face)))
-
(defun vc-hg-dir-extra-headers (dir)
- "Generate extra status headers for a Mercurial tree."
+ "Generate extra status headers for a repository in DIR.
+This runs the command \"hg summary\"."
(let ((default-directory dir))
- (concat
- (vc-hg-dir-extra-header "Root : " "root") "\n"
- (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n"
- (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n"
- ;; these change after each commit
- ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n"
- ;; (vc-hg-dir-extra-header "Global id : " "id" "-i")
- )))
+ (with-temp-buffer
+ (vc-hg-command t 0 nil "summary")
+ (goto-char (point-min))
+ (mapconcat
+ #'identity
+ (let (result)
+ (while (not (eobp))
+ (push
+ (let ((entry (if (looking-at "\\([^ ].*\\): \\(.*\\)")
+ (cons (capitalize (match-string 1)) (match-string
2))
+ (cons "" (buffer-substring (point)
(line-end-position))))))
+ (concat
+ (propertize (format "%-11s: " (car entry)) 'face
'font-lock-type-face)
+ (propertize (cdr entry) 'face 'font-lock-variable-name-face)))
+ result)
+ (forward-line))
+ (nreverse result))
+ "\n"))))
(defun vc-hg-log-incoming (buffer remote-location)
(vc-setup-buffer buffer)
diff --git a/lisp/wdired.el b/lisp/wdired.el
index 768b8f5..b98becf 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -609,7 +609,10 @@ Optional arguments are ignored."
(defun wdired--restore-dired-filename-prop (beg end _len)
(save-match-data
(save-excursion
- (let ((lep (line-end-position)))
+ (let ((lep (line-end-position))
+ (used-F (dired-check-switches
+ dired-actual-switches
+ "F" "classify")))
(beginning-of-line)
(when (re-search-forward
directory-listing-before-filename-regexp lep t)
@@ -623,13 +626,17 @@ Optional arguments are ignored."
(and (re-search-backward
dired-permission-flags-regexp nil t)
(looking-at "l")
- (search-forward " -> " lep t))
+ ;; macOS and Ultrix adds "@" to the end
+ ;; of symlinks when using -F.
+ (if (and used-F
+ dired-ls-F-marks-symlinks)
+ (re-search-forward "@? -> " lep t)
+ (search-forward " -> " lep t)))
;; When dired-listing-switches includes "F"
;; or "classify", don't treat appended
;; indicator characters as part of the file
;; name (bug#34915).
- (and (dired-check-switches dired-actual-switches
- "F" "classify")
+ (and used-F
(re-search-forward "[*/@|=>]$" lep t)))
(goto-char (match-beginning 0))
lep))
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index 47434bf..42c4b61 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -283,7 +283,8 @@
'(face
tabs spaces trailing lines space-before-tab newline
indentation empty space-after-tab
- space-mark tab-mark newline-mark)
+ space-mark tab-mark newline-mark
+ missing-newline-at-eof)
"Specify which kind of blank is visualized.
It's a list containing some or all of the following values:
@@ -326,6 +327,11 @@ It's a list containing some or all of the following values:
It has effect only if `face' (see above)
is present in `whitespace-style'.
+ missing-newline-at-eof Missing newline at the end of the file is
+ visualized via faces.
+ It has effect only if `face' (see above)
+ is present in `whitespace-style'.
+
empty empty lines at beginning and/or end of buffer
are visualized via faces.
It has effect only if `face' (see above)
@@ -586,6 +592,10 @@ line. Used when `whitespace-style' includes the value
`indentation'.")
"Face used to visualize big indentation."
:group 'whitespace)
+(defface whitespace-missing-newline-at-eof
+ '((((class mono)) :inverse-video t :weight bold :underline t)
+ (t :background "#d0d040" :foreground "black"))
+ "Face used to visualize missing newline at the end of the file.")
(defvar whitespace-empty 'whitespace-empty
"Symbol face used to visualize empty lines at beginning and/or end of buffer.
@@ -1700,6 +1710,8 @@ cleaning up these problems."
(whitespace-space-after-tab-regexp 'tab))
((eq (car option) 'space-after-tab::space)
(whitespace-space-after-tab-regexp 'space))
+ ((eq (car option) 'missing-newline-at-eof)
+ "[^\n]\\'")
(t
(cdr option)))))
(when (re-search-forward regexp rend t)
@@ -2122,7 +2134,16 @@ resultant list will be returned."
((memq 'space-after-tab::space whitespace-active-style)
;; Show SPACEs after TAB (TABs).
(whitespace-space-after-tab-regexp 'space)))
- 1 whitespace-space-after-tab t)))))
+ 1 whitespace-space-after-tab t)))
+ ,@(when (memq 'missing-newline-at-eof whitespace-active-style)
+ ;; Show missing newline.
+ `(("[^\n]\\'" 0
+ ;; Don't mark the end of the buffer is point is there --
+ ;; it probably means that the user is typing something
+ ;; at the end of the buffer.
+ (and (/= whitespace-point (point-max))
+ 'whitespace-missing-newline-at-eof)
+ t)))))
(font-lock-add-keywords nil whitespace-font-lock-keywords t)
(font-lock-flush)))
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 284fd1d..ea7e266 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -577,6 +577,63 @@ respectively."
(if (and widget (funcall function widget maparg))
(setq overlays nil)))))
+(defun widget-describe (&optional widget-or-pos)
+ "Describe the widget at point.
+Displays a buffer with information about the widget (e.g., its actions) as well
+as a link to browse all the properties of the widget.
+
+This command resolves the indirection of widgets running the action of its
+parents, so the real action executed can be known.
+
+When called from Lisp, pass WIDGET-OR-POS as the widget to describe,
+or a buffer position where a widget is present. If WIDGET-OR-POS is nil,
+the widget at point is the widget to describe."
+ (interactive "d")
+ (require 'wid-browse) ; The widget-browse widget.
+ (let ((widget (if (widgetp widget-or-pos)
+ widget-or-pos
+ (widget-at widget-or-pos)))
+ props)
+ (when widget
+ (help-setup-xref (list #'widget-describe widget)
+ (called-interactively-p 'interactive))
+ (setq props (list (cons 'action (widget--resolve-parent-action widget))
+ (cons 'mouse-down-action
+ (widget-get widget :mouse-down-action))))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (widget-insert "This widget's type is ")
+ (widget-create 'widget-browse :format "%[%v%]\n%d"
+ :doc (get (car widget) 'widget-documentation)
+ :help-echo "Browse this widget's properties"
+ widget)
+ (dolist (action '(action mouse-down-action))
+ (let ((name (symbol-name action))
+ (val (alist-get action props)))
+ (when (functionp val)
+ (widget-insert "\n\n" (propertize (capitalize name) 'face
'bold)
+ "'\nThe " name " of this widget is")
+ (if (symbolp val)
+ (progn (widget-insert " ")
+ (widget-create 'function-link :value val
+ :button-prefix "" :button-suffix ""
+ :help-echo "Describe this function"))
+ (widget-insert "\n")
+ (princ val)))))))
+ (widget-setup)
+ t)))
+
+(defun widget--resolve-parent-action (widget)
+ "Resolve the real action of WIDGET up its inheritance chain.
+Follow the WIDGET's parents, until its :action is no longer
+`widget-parent-action', and return its value."
+ (let ((action (widget-get widget :action))
+ (parent (widget-get widget :parent)))
+ (while (eq action 'widget-parent-action)
+ (setq parent (widget-get parent :parent)
+ action (widget-get parent :action)))
+ action))
+
;;; Images.
(defcustom widget-image-directory (file-name-as-directory
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index b22af5cc..1d49f46 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -1,4 +1,4 @@
-;;; x-dnd.el --- drag and drop support for X
+;;; x-dnd.el --- drag and drop support for X -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2020 Free Software Foundation, Inc.
@@ -32,7 +32,7 @@
(require 'dnd)
;;; Customizable variables
-(defcustom x-dnd-test-function 'x-dnd-default-test-function
+(defcustom x-dnd-test-function #'x-dnd-default-test-function
"The function drag and drop uses to determine if to accept or reject a drop.
The function takes three arguments, WINDOW, ACTION and TYPES.
WINDOW is where the mouse is when the function is called. WINDOW may be a
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index d3e98c5..b777f84 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,4 +1,4 @@
-# alloca.m4 serial 16
+# alloca.m4 serial 17
dnl Copyright (C) 2002-2004, 2006-2007, 2009-2020 Free Software Foundation,
dnl Inc.
dnl This file is free software; the Free Software Foundation
@@ -50,10 +50,13 @@ AC_DEFUN([gl_FUNC_ALLOCA],
# STACK_DIRECTION is already handled by AC_FUNC_ALLOCA.
AC_DEFUN([gl_PREREQ_ALLOCA], [:])
-# This works around a bug in autoconf <= 2.68.
-# See <https://lists.gnu.org/r/bug-gnulib/2011-06/msg00277.html> and
-#
<https://git.savannah.gnu.org/gitweb/?p=autoconf.git;a=commitdiff;h=6cd9f12520b0d6f76d3230d7565feba1ecf29497>.
-# Also it has a simplification that is not yet in Autoconf.
+m4_version_prereq([2.70], [], [
+
+# This works around a bug in autoconf <= 2.68 and has simplifications
+# from 2.70. See:
+# https://lists.gnu.org/r/bug-gnulib/2011-06/msg00277.html
+#
https://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=6cd9f12520b0d6f76d3230d7565feba1ecf29497
+#
https://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=15edf7fd8094fd14a89d9891dd72a9624762597a
# _AC_LIBOBJ_ALLOCA
# -----------------
@@ -102,3 +105,4 @@ AH_VERBATIM([STACK_DIRECTION],
@%:@undef STACK_DIRECTION])dnl
AC_DEFINE_UNQUOTED(STACK_DIRECTION, $ac_cv_c_stack_direction)
])
+])
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 57f3a78..50acc0a 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,4 +1,4 @@
-# gnulib-common.m4 serial 52
+# gnulib-common.m4 serial 53
dnl Copyright (C) 2007-2020 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -300,7 +300,9 @@ AC_DEFUN([gl_COMMON_BODY], [
#define _GL_ASYNC_SAFE
])
AH_VERBATIM([micro_optimizations],
-[/* _GL_CMP (n1, n2) performs a three-valued comparison on n1 vs. n2.
+[/* _GL_CMP (n1, n2) performs a three-valued comparison on n1 vs. n2, where
+ n1 and n2 are expressions without side effects, that evaluate to real
+ numbers (excluding NaN).
It returns
1 if n1 > n2
0 if n1 == n2
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 4472af8..5bfa147 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -346,7 +346,7 @@ AC_DEFUN([gl_INIT],
AC_REQUIRE([gl_LARGEFILE])
gl___INLINE
gl_LIBGMP
- if test -n "$GMP_H"; then
+ if test $HAVE_LIBGMP != yes; then
AC_LIBOBJ([mini-gmp-gnulib])
fi
gl_LIMITS_H
diff --git a/m4/largefile.m4 b/m4/largefile.m4
index 8017ca7..f7140dd 100644
--- a/m4/largefile.m4
+++ b/m4/largefile.m4
@@ -35,7 +35,7 @@ m4_define([_AC_SYS_LARGEFILE_TEST_INCLUDES],
We can't simply define LARGE_OFF_T to be 9223372036854775807,
since some C++ compilers masquerading as C compilers
incorrectly reject 9223372036854775807. */
-@%:@define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
+@%:@define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))
int off_t_is_large[[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1]];[]dnl
diff --git a/m4/libgmp.m4 b/m4/libgmp.m4
index 82c065e..1025f06 100644
--- a/m4/libgmp.m4
+++ b/m4/libgmp.m4
@@ -1,4 +1,4 @@
-# libgmp.m4 serial 4
+# libgmp.m4 serial 5
# Configure the GMP library or a replacement.
dnl Copyright 2020 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
@@ -18,50 +18,54 @@ AC_DEFUN([gl_LIBGMP],
[AS_HELP_STRING([--without-libgmp],
[do not use the GNU Multiple Precision (GMP) library;
this is the default on systems lacking libgmp.])])
- case "$with_libgmp" in
- no)
- HAVE_LIBGMP=no
- LIBGMP=
- LTLIBGMP=
- ;;
- *)
- dnl Prefer AC_LIB_HAVE_LINKFLAGS if the havelib module is also in use.
- m4_ifdef([gl_HAVE_MODULE_HAVELIB],
- [AC_LIB_HAVE_LINKFLAGS([gmp], [],
- [#include <gmp.h>],
- [static const mp_limb_t x[2] = { 0x73, 0x55 };
- mpz_t tmp;
- mpz_roinit_n (tmp, x, 2);
- ],
- [no])],
- [gl_saved_LIBS=$LIBS
- AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp])
- LIBS=$gl_saved_LIBS
- case $ac_cv_search___gmpz_roinit_n in
- 'none needed')
- HAVE_LIBGMP=yes LIBGMP=;;
- -*)
- HAVE_LIBGMP=yes LIBGMP=$ac_cv_search___gmpz_roinit_n;;
- *)
- HAVE_LIBGMP=no LIBGMP=;;
- esac
- LTLIBGMP=$LIBGMP
- AC_SUBST([HAVE_LIBGMP])
- AC_SUBST([LIBGMP])
- AC_SUBST([LTLIBGMP])])
- if test "$with_libgmp,$HAVE_LIBGMP" = yes,no; then
- AC_MSG_ERROR(
- [GMP not found, although --with-libgmp was specified.m4_ifdef(
- [AC_LIB_HAVE_LINKFLAGS],
- [ Try specifying --with-libgmp-prefix=DIR.])])
- fi
- ;;
- esac
- if test $HAVE_LIBGMP = yes; then
+ HAVE_LIBGMP=no
+ LIBGMP=
+ LTLIBGMP=
+ AS_IF([test "$with_libgmp" != no],
+ [AC_CHECK_HEADERS([gmp.h gmp/gmp.h], [break])
+ dnl Prefer AC_LIB_HAVE_LINKFLAGS if the havelib module is also in use.
+ AS_IF([test "$ac_cv_header_gmp_h" = yes ||
+ test "$ac_cv_header_gmp_gmp_h" = yes],
+ [m4_ifdef([gl_HAVE_MODULE_HAVELIB],
+ [AC_LIB_HAVE_LINKFLAGS([gmp], [],
+ [#if HAVE_GMP_H
+ # include <gmp.h>
+ #else
+ # include <gmp/gmp.h>
+ #endif],
+ [static const mp_limb_t x[2] = { 0x73, 0x55 };
+ mpz_t tmp;
+ mpz_roinit_n (tmp, x, 2);
+ ],
+ [no])],
+ [gl_saved_LIBS=$LIBS
+ AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp])
+ LIBS=$gl_saved_LIBS
+ case $ac_cv_search___gmpz_roinit_n in
+ 'none needed')
+ HAVE_LIBGMP=yes;;
+ -*)
+ HAVE_LIBGMP=yes
+ LIBGMP=$ac_cv_search___gmpz_roinit_n
+ LTLIBGMP=$LIBGMP;;
+ esac
+ AC_SUBST([HAVE_LIBGMP])
+ AC_SUBST([LIBGMP])
+ AC_SUBST([LTLIBGMP])])])
+ if test "$with_libgmp,$HAVE_LIBGMP" = yes,no; then
+ AC_MSG_ERROR(
+ [GMP not found, although --with-libgmp was specified.m4_ifdef(
+ [AC_LIB_HAVE_LINKFLAGS],
+ [ Try specifying --with-libgmp-prefix=DIR.])])
+ fi])
+ if test $HAVE_LIBGMP = yes && test "$ac_cv_header_gmp_h" = yes; then
GMP_H=
else
GMP_H=gmp.h
fi
AC_SUBST([GMP_H])
- AM_CONDITIONAL([GL_GENERATE_GMP_H], [test -n "$GMP_H"])
+ AM_CONDITIONAL([GL_GENERATE_MINI_GMP_H],
+ [test $HAVE_LIBGMP != yes])
+ AM_CONDITIONAL([GL_GENERATE_GMP_GMP_H],
+ [test $HAVE_LIBGMP = yes && test "$ac_cv_header_gmp_h" != yes])
])
diff --git a/src/alloc.c b/src/alloc.c
index 12f53bd..738a35c 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -34,7 +34,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "bignum.h"
#include "dispextern.h"
#include "intervals.h"
-#include "ptr-bounds.h"
#include "puresize.h"
#include "sheap.h"
#include "sysstdio.h"
@@ -1624,8 +1623,7 @@ static struct Lisp_String *string_free_list;
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \
- - SDATA_DATA_OFFSET))
+#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET))
#ifdef GC_CHECK_STRING_OVERRUN
@@ -1799,7 +1797,7 @@ allocate_string (void)
/* Every string on a free list should have NULL data pointer. */
s->u.s.data = NULL;
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = ptr_bounds_clip (s, sizeof *s);
+ string_free_list = s;
}
}
@@ -1908,7 +1906,7 @@ allocate_string_data (struct Lisp_String *s,
MALLOC_UNBLOCK_INPUT;
- s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1);
+ s->u.s.data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
SDATA_NBYTES (data) = nbytes;
#endif
@@ -2036,7 +2034,7 @@ sweep_strings (void)
/* Put the string on the free-list. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = ptr_bounds_clip (s, sizeof *s);
+ string_free_list = s;
++nfree;
}
}
@@ -2044,7 +2042,7 @@ sweep_strings (void)
{
/* S was on the free-list before. Put it there again. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
- string_free_list = ptr_bounds_clip (s, sizeof *s);
+ string_free_list = s;
++nfree;
}
}
@@ -2171,8 +2169,7 @@ compact_small_strings (void)
{
eassert (tb != b || to < from);
memmove (to, from, size + GC_STRING_EXTRA);
- to->string->u.s.data
- = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1);
+ to->string->u.s.data = SDATA_DATA (to);
}
/* Advance past the sdata we copied to. */
@@ -2959,7 +2956,6 @@ Lisp_Object zero_vector;
static void
setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
{
- v = ptr_bounds_clip (v, nbytes);
eassume (header_size <= nbytes);
ptrdiff_t nwords = (nbytes - header_size) / word_size;
XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords);
@@ -3327,7 +3323,7 @@ allocate_vectorlike (ptrdiff_t len, bool clearit)
MALLOC_UNBLOCK_INPUT;
- return ptr_bounds_clip (p, nbytes);
+ return p;
}
@@ -4481,7 +4477,6 @@ live_string_holding (struct mem_node *m, void *p)
must not be on the free-list. */
if (0 <= offset && offset < sizeof b->strings)
{
- cp = ptr_bounds_copy (cp, b);
struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
if (s->u.s.data)
return s;
@@ -4514,7 +4509,6 @@ live_cons_holding (struct mem_node *m, void *p)
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index))
{
- cp = ptr_bounds_copy (cp, b);
struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
if (!deadp (s->u.s.car))
return s;
@@ -4548,7 +4542,6 @@ live_symbol_holding (struct mem_node *m, void *p)
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index))
{
- cp = ptr_bounds_copy (cp, b);
struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
if (!deadp (s->u.s.function))
return s;
@@ -4645,7 +4638,7 @@ mark_maybe_object (Lisp_Object obj)
#endif
int type_tag = XTYPE (obj);
- intptr_t offset;
+ intptr_t pointer_word_tag = LISP_WORD_TAG (type_tag), offset, ipo;
switch (type_tag)
{
@@ -4661,16 +4654,8 @@ mark_maybe_object (Lisp_Object obj)
break;
}
- bool overflow
- = INT_SUBTRACT_WRAPV (offset, LISP_WORD_TAG (type_tag), &offset);
-#if !defined WIDE_EMACS_INT || USE_LSB_TAG
- /* If we don't use wide integers, then `intptr_t' should always be
- large enough to not overflow. Furthermore, when using the least
- significant bits as tag bits, the tag is small enough to not
- overflow either. */
- eassert (!overflow);
-#endif
- void *po = (char *) ((intptr_t) (char *) XLP (obj) + offset);
+ INT_ADD_WRAPV ((intptr_t) XLP (obj), offset - pointer_word_tag, &ipo);
+ void *po = (void *) ipo;
/* If the pointer is in the dump image and the dump has a record
of the object starting at the place where the pointer points, we
@@ -4873,7 +4858,7 @@ mark_memory (void const *start, void const *end)
for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT)
{
- char *p = *(char *const *) pp;
+ void *p = *(void *const *) pp;
mark_maybe_pointer (p);
/* Unmask any struct Lisp_Symbol pointer that make_lisp_symbol
@@ -4881,8 +4866,9 @@ mark_memory (void const *start, void const *end)
On a host with 32-bit pointers and 64-bit Lisp_Objects,
a Lisp_Object might be split into registers saved into
non-adjacent words and P might be the low-order word's value. */
- p = (char *) ((uintptr_t) p + (uintptr_t) lispsym);
- mark_maybe_pointer (p);
+ intptr_t ip;
+ INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip);
+ mark_maybe_pointer ((void *) ip);
verify (alignof (Lisp_Object) % GC_POINTER_ALIGNMENT == 0);
if (alignof (Lisp_Object) == GC_POINTER_ALIGNMENT
@@ -5261,7 +5247,7 @@ pure_alloc (size_t size, int type)
pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
if (pure_bytes_used <= pure_size)
- return ptr_bounds_clip (result, size);
+ return result;
/* Don't allocate a large amount here,
because it might get mmap'd and then its address
@@ -5352,7 +5338,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t
nbytes)
/* Check the remaining characters. */
if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
/* Found. */
- return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1);
+ return non_lisp_beg + start;
start += last_char_skip;
}
@@ -6076,7 +6062,6 @@ garbage_collect (void)
stack_copy = xrealloc (stack_copy, stack_size);
stack_copy_size = stack_size;
}
- stack = ptr_bounds_set (stack, stack_size);
no_sanitize_memcpy (stack_copy, stack, stack_size);
}
}
@@ -6922,8 +6907,7 @@ sweep_conses (void)
for (pos = start; pos < stop; pos++)
{
- struct Lisp_Cons *acons
- = ptr_bounds_copy (&cblk->conses[pos], cblk);
+ struct Lisp_Cons *acons = &cblk->conses[pos];
if (!XCONS_MARKED_P (acons))
{
this_free++;
@@ -6976,7 +6960,7 @@ sweep_floats (void)
int this_free = 0;
for (int i = 0; i < lim; i++)
{
- struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk);
+ struct Lisp_Float *afloat = &fblk->floats[i];
if (!XFLOAT_MARKED_P (afloat))
{
this_free++;
diff --git a/src/buffer.c b/src/buffer.c
index e441499..241f2d4 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -28,10 +28,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <stdlib.h>
#include <unistd.h>
-#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H
-#include <sanitizer/lsan_interface.h>
-#endif
-
#include <verify.h>
#include "lisp.h"
@@ -5087,9 +5083,7 @@ enlarge_buffer_text (struct buffer *b, ptrdiff_t delta)
#else
p = xrealloc (b->text->beg, new_nbytes);
#endif
-#ifdef HAVE___LSAN_IGNORE_OBJECT
__lsan_ignore_object (p);
-#endif
if (p == NULL)
{
diff --git a/src/bytecode.c b/src/bytecode.c
index 5ac30aa..1913a48 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -24,7 +24,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "character.h"
#include "buffer.h"
#include "keyboard.h"
-#include "ptr-bounds.h"
#include "syntax.h"
#include "window.h"
@@ -47,7 +46,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
indirect threaded, using GCC's computed goto extension. This code,
as currently implemented, is incompatible with BYTE_CODE_SAFE and
BYTE_CODE_METER. */
-#if (defined __GNUC__ && !defined __STRICT_ANSI__ && !defined __CHKP__ \
+#if (defined __GNUC__ && !defined __STRICT_ANSI__ \
&& !BYTE_CODE_SAFE && !defined BYTE_CODE_METER)
#define BYTE_CODE_THREADED
#endif
@@ -368,14 +367,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
USE_SAFE_ALLOCA;
void *alloc;
SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length);
- ptrdiff_t item_bytes = stack_items * word_size;
- Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes);
+ Lisp_Object *stack_base = alloc;
Lisp_Object *top = stack_base;
*top = vector; /* Ensure VECTOR survives GC (Bug#33014). */
Lisp_Object *stack_lim = stack_base + stack_items;
- unsigned char *bytestr_data = alloc;
- bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length);
- memcpy (bytestr_data, SDATA (bytestr), bytestr_length);
+ unsigned char const *bytestr_data = memcpy (stack_lim,
+ SDATA (bytestr), bytestr_length);
unsigned char const *pc = bytestr_data;
ptrdiff_t count = SPECPDL_INDEX ();
diff --git a/src/callint.c b/src/callint.c
index eb91635..f609c96 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -21,7 +21,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <config.h>
#include "lisp.h"
-#include "ptr-bounds.h"
#include "character.h"
#include "buffer.h"
#include "keyboard.h"
@@ -440,9 +439,6 @@ invoke it (via an `interactive' spec that contains, for
instance, an
signed char *varies = (signed char *) (visargs + nargs);
memclear (args, nargs * (2 * word_size + 1));
- args = ptr_bounds_clip (args, nargs * sizeof *args);
- visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs);
- varies = ptr_bounds_clip (varies, nargs * sizeof *varies);
if (!NILP (enable))
specbind (Qenable_recursive_minibuffers, Qt);
diff --git a/src/data.c b/src/data.c
index e827695..3371136 100644
--- a/src/data.c
+++ b/src/data.c
@@ -23,10 +23,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <math.h>
#include <stdio.h>
-#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H
-#include <sanitizer/lsan_interface.h>
-#endif
-
#include <byteswap.h>
#include <count-one-bits.h>
#include <count-trailing-zeros.h>
@@ -1834,9 +1830,7 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded,
set_blv_defcell (blv, tem);
set_blv_valcell (blv, tem);
set_blv_found (blv, false);
-#ifdef HAVE___LSAN_IGNORE_OBJECT
__lsan_ignore_object (blv);
-#endif
return blv;
}
diff --git a/src/dispnew.c b/src/dispnew.c
index 1ae59e3..d318e26 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -25,7 +25,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <unistd.h>
#include "lisp.h"
-#include "ptr-bounds.h"
#include "termchar.h"
/* cm.h must come after dispextern.h on Windows. */
#include "dispextern.h"
@@ -4891,12 +4890,6 @@ scrolling (struct frame *frame)
unsigned *new_hash = old_hash + height;
int *draw_cost = (int *) (new_hash + height);
int *old_draw_cost = draw_cost + height;
- old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash);
- new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash);
- draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost);
- old_draw_cost = ptr_bounds_clip (old_draw_cost,
- height * sizeof *old_draw_cost);
-
eassert (current_matrix);
/* Compute hash codes of all the lines. Also calculate number of
diff --git a/src/editfns.c b/src/editfns.c
index 763d95b..cb09ea8 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -46,7 +46,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "intervals.h"
-#include "ptr-bounds.h"
#include "systime.h"
#include "character.h"
#include "buffer.h"
@@ -3131,8 +3130,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool
message)
string was not copied into the output.
It is 2 if byte I was not the first byte of its character. */
char *discarded = (char *) &info[nspec_bound];
- info = ptr_bounds_clip (info, info_size);
- discarded = ptr_bounds_clip (discarded, formatlen);
memset (discarded, 0, formatlen);
/* Try to determine whether the result should be multibyte.
diff --git a/src/emacs-module.c b/src/emacs-module.c
index f571019..a0bab11 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -84,10 +84,6 @@ To add a new module function, proceed as follows:
#include <stdlib.h>
#include <time.h>
-#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H
-#include <sanitizer/lsan_interface.h>
-#endif
-
#include "lisp.h"
#include "bignum.h"
#include "dynlib.h"
@@ -1103,9 +1099,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
if (module_assertions)
{
rt = xmalloc (sizeof *rt);
-#ifdef HAVE___LSAN_IGNORE_OBJECT
__lsan_ignore_object (rt);
-#endif
}
else
rt = &rt_pub;
@@ -1426,9 +1420,7 @@ initialize_environment (emacs_env *env, struct
emacs_env_private *priv)
if (module_assertions)
{
env = xmalloc (sizeof *env);
-#ifdef HAVE___LSAN_IGNORE_OBJECT
__lsan_ignore_object (env);
-#endif
}
priv->pending_non_local_exit = emacs_funcall_exit_return;
diff --git a/src/emacs.c b/src/emacs.c
index 34717cd..8c25227 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -83,7 +83,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "charset.h"
#include "composite.h"
#include "dispextern.h"
-#include "ptr-bounds.h"
#include "regex-emacs.h"
#include "sheap.h"
#include "syntax.h"
diff --git a/src/frame.c b/src/frame.c
index c871e4f..c4dfc35 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -35,7 +35,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "buffer.h"
/* These help us bind and responding to switch-frame events. */
#include "keyboard.h"
-#include "ptr-bounds.h"
#include "frame.h"
#include "blockinput.h"
#include "termchar.h"
@@ -2566,21 +2565,18 @@ before calling this function on it, like this.
if (FRAME_WINDOW_P (XFRAME (frame)))
/* Warping the mouse will cause enternotify and focus events. */
frame_set_mouse_position (XFRAME (frame), xval, yval);
-#else
-#if defined (MSDOS)
+#elif defined MSDOS
if (FRAME_MSDOS_P (XFRAME (frame)))
{
Fselect_frame (frame, Qnil);
mouse_moveto (xval, yval);
}
+#elif defined HAVE_GPM
+ Fselect_frame (frame, Qnil);
+ term_mouse_moveto (xval, yval);
#else
-#ifdef HAVE_GPM
- {
- Fselect_frame (frame, Qnil);
- term_mouse_moveto (xval, yval);
- }
-#endif
-#endif
+ (void) xval;
+ (void) yval;
#endif
return Qnil;
@@ -2607,21 +2603,18 @@ before calling this function on it, like this.
if (FRAME_WINDOW_P (XFRAME (frame)))
/* Warping the mouse will cause enternotify and focus events. */
frame_set_mouse_pixel_position (XFRAME (frame), xval, yval);
-#else
-#if defined (MSDOS)
+#elif defined MSDOS
if (FRAME_MSDOS_P (XFRAME (frame)))
{
Fselect_frame (frame, Qnil);
mouse_moveto (xval, yval);
}
+#elif defined HAVE_GPM
+ Fselect_frame (frame, Qnil);
+ term_mouse_moveto (xval, yval);
#else
-#ifdef HAVE_GPM
- {
- Fselect_frame (frame, Qnil);
- term_mouse_moveto (xval, yval);
- }
-#endif
-#endif
+ (void) xval;
+ (void) yval;
#endif
return Qnil;
@@ -3658,6 +3651,9 @@ bottom edge of FRAME's display. */)
#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_TERMINAL (f)->set_frame_offset_hook)
FRAME_TERMINAL (f)->set_frame_offset_hook (f, xval, yval, 1);
+#else
+ (void) xval;
+ (void) yval;
#endif
}
@@ -5019,8 +5015,6 @@ gui_display_get_resource (Display_Info *dpyinfo,
Lisp_Object attribute,
USE_SAFE_ALLOCA;
char *name_key = SAFE_ALLOCA (name_keysize + class_keysize);
char *class_key = name_key + name_keysize;
- name_key = ptr_bounds_clip (name_key, name_keysize);
- class_key = ptr_bounds_clip (class_key, class_keysize);
/* Start with emacs.FRAMENAME for the name (the specific one)
and with `Emacs' for the class key (the general one). */
@@ -5091,9 +5085,6 @@ x_get_resource_string (const char *attribute, const char
*class)
ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2;
char *name_key = SAFE_ALLOCA (name_keysize + class_keysize);
char *class_key = name_key + name_keysize;
- name_key = ptr_bounds_clip (name_key, name_keysize);
- class_key = ptr_bounds_clip (class_key, class_keysize);
-
esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute);
sprintf (class_key, "%s.%s", EMACS_CLASS, class);
diff --git a/src/fringe.c b/src/fringe.c
index fc4c738..c3d64fe 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -23,7 +23,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "frame.h"
-#include "ptr-bounds.h"
#include "window.h"
#include "dispextern.h"
#include "buffer.h"
@@ -1607,9 +1606,7 @@ If BITMAP already exists, the existing definition is
replaced. */)
fb.dynamic = true;
xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW);
- fb.bits = b = ((unsigned short *)
- ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW));
- xfb = ptr_bounds_clip (xfb, sizeof *xfb);
+ fb.bits = b = (unsigned short *) (xfb + 1);
j = 0;
while (j < fb.height)
diff --git a/src/gmalloc.c b/src/gmalloc.c
index 8450a63..3560c74 100644
--- a/src/gmalloc.c
+++ b/src/gmalloc.c
@@ -38,8 +38,6 @@ License along with this library. If not, see
<https://www.gnu.org/licenses/>.
#include "lisp.h"
-#include "ptr-bounds.h"
-
#ifdef HAVE_MALLOC_H
# if GNUC_PREREQ (4, 2, 0)
# pragma GCC diagnostic ignored "-Wdeprecated-declarations"
@@ -200,8 +198,7 @@ extern size_t _bytes_free;
/* Internal versions of `malloc', `realloc', and `free'
used when these functions need to call each other.
- They are the same but don't call the hooks
- and don't bound the resulting pointers. */
+ They are the same but don't call the hooks. */
extern void *_malloc_internal (size_t);
extern void *_realloc_internal (void *, size_t);
extern void _free_internal (void *);
@@ -551,7 +548,7 @@ malloc_initialize_1 (void)
_heapinfo[0].free.size = 0;
_heapinfo[0].free.next = _heapinfo[0].free.prev = 0;
_heapindex = 0;
- _heapbase = (char *) ptr_bounds_init (_heapinfo);
+ _heapbase = (char *) _heapinfo;
_heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info));
register_heapinfo ();
@@ -912,8 +909,7 @@ malloc (size_t size)
among multiple threads. We just leave it for compatibility with
glibc malloc (i.e., assignments to gmalloc_hook) for now. */
hook = gmalloc_hook;
- void *result = (hook ? hook : _malloc_internal) (size);
- return ptr_bounds_clip (result, size);
+ return (hook ? hook : _malloc_internal) (size);
}
#if !(defined (_LIBC) || defined (HYBRID_MALLOC))
@@ -991,7 +987,6 @@ _free_internal_nolock (void *ptr)
if (ptr == NULL)
return;
- ptr = ptr_bounds_init (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1303,7 +1298,6 @@ _realloc_internal_nolock (void *ptr, size_t size)
else if (ptr == NULL)
return _malloc_internal_nolock (size);
- ptr = ptr_bounds_init (ptr);
block = BLOCK (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1426,8 +1420,7 @@ realloc (void *ptr, size_t size)
return NULL;
hook = grealloc_hook;
- void *result = (hook ? hook : _realloc_internal) (ptr, size);
- return ptr_bounds_clip (result, size);
+ return (hook ? hook : _realloc_internal) (ptr, size);
}
/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc.
@@ -1601,7 +1594,6 @@ aligned_alloc (size_t alignment, size_t size)
{
l->exact = result;
result = l->aligned = (char *) result + adj;
- result = ptr_bounds_clip (result, size);
}
UNLOCK_ALIGNED_BLOCKS ();
if (l == NULL)
diff --git a/src/image.c b/src/image.c
index e7e0a93..e236b38 100644
--- a/src/image.c
+++ b/src/image.c
@@ -259,6 +259,8 @@ cr_put_image_to_cr_data (struct image *img)
cairo_matrix_t matrix;
cairo_pattern_get_matrix (img->cr_data, &matrix);
cairo_pattern_set_matrix (pattern, &matrix);
+ cairo_pattern_set_filter
+ (pattern, cairo_pattern_get_filter (img->cr_data));
cairo_pattern_destroy (img->cr_data);
}
cairo_surface_destroy (surface);
@@ -2114,6 +2116,15 @@ image_set_transform (struct frame *f, struct image *img)
double rotation = 0.0;
compute_image_rotation (img, &rotation);
+# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS
+ /* We want scale up operations to use a nearest neighbour filter to
+ show real pixels instead of munging them, but scale down
+ operations to use a blended filter, to avoid aliasing and the like.
+
+ TODO: implement for Windows. */
+ bool scale_down = (width < img->width) || (height < img->height);
+# endif
+
/* Perform scale transformation. */
matrix3x3 matrix
@@ -2225,11 +2236,14 @@ image_set_transform (struct frame *f, struct image *img)
/* Under NS the transform is applied to the drawing surface at
drawing time, so store it for later. */
ns_image_set_transform (img->pixmap, matrix);
+ ns_image_set_smoothing (img->pixmap, scale_down);
# elif defined USE_CAIRO
cairo_matrix_t cr_matrix = {matrix[0][0], matrix[0][1], matrix[1][0],
matrix[1][1], matrix[2][0], matrix[2][1]};
cairo_pattern_t *pattern = cairo_pattern_create_rgb (0, 0, 0);
cairo_pattern_set_matrix (pattern, &cr_matrix);
+ cairo_pattern_set_filter (pattern, scale_down
+ ? CAIRO_FILTER_BEST : CAIRO_FILTER_NEAREST);
/* Dummy solid color pattern just to record pattern matrix. */
img->cr_data = pattern;
# elif defined (HAVE_XRENDER)
@@ -2246,14 +2260,14 @@ image_set_transform (struct frame *f, struct image *img)
XDoubleToFixed (matrix[1][2]),
XDoubleToFixed (matrix[2][2])}}};
- XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, FilterBest,
- 0, 0);
+ XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture,
+ scale_down ? FilterBest : FilterNearest, 0, 0);
XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->picture, &tmat);
if (img->mask_picture)
{
XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->mask_picture,
- FilterBest, 0, 0);
+ scale_down ? FilterBest : FilterNearest, 0,
0);
XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->mask_picture,
&tmat);
}
diff --git a/src/lisp.h b/src/lisp.h
index 5ef31ef..75ef6d3 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -894,8 +894,8 @@ verify (GCALIGNED (struct Lisp_Symbol));
convert it to a Lisp_Word. */
#if LISP_WORDS_ARE_POINTERS
/* untagged_ptr is a pointer so that the compiler knows that TAG_PTR
- yields a pointer; this can help with gcc -fcheck-pointer-bounds.
- It is char * so that adding a tag uses simple machine addition. */
+ yields a pointer. It is char * so that adding a tag uses simple
+ machine addition. */
typedef char *untagged_ptr;
typedef uintptr_t Lisp_Word_tag;
#else
@@ -923,13 +923,9 @@ typedef EMACS_UINT Lisp_Word_tag;
when using a debugger like GDB, on older platforms where the debug
format does not represent C macros. However, they are unbounded
and would just be asking for trouble if checking pointer bounds. */
-#ifdef __CHKP__
-# define DEFINE_LISP_SYMBOL(name)
-#else
-# define DEFINE_LISP_SYMBOL(name) \
- DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
- DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name))
-#endif
+#define DEFINE_LISP_SYMBOL(name) \
+ DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
+ DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name))
/* The index of the C-defined Lisp symbol SYM.
This can be used in a static initializer. */
@@ -1003,30 +999,15 @@ XSYMBOL (Lisp_Object a)
eassert (SYMBOLP (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
-#ifdef __CHKP__
- /* Bypass pointer checking. Although this could be improved it is
- probably not worth the trouble. */
- p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol));
-#endif
return p;
}
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
-#ifdef __CHKP__
- /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)'
- should be more efficient, it runs afoul of GCC bug 83251
- <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=83251>.
- Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym)
- here seems to trigger a GCC bug, as yet undiagnosed. */
- char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym);
- char *symoffset = addr - (intptr_t) lispsym;
-#else
- /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is
+ /* GCC 7 x86-64 generates faster code if lispsym is
cast to char * rather than to intptr_t. */
char *symoffset = (char *) ((char *) sym - (char *) lispsym);
-#endif
Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
@@ -4837,6 +4818,17 @@ lispstpcpy (char *dest, Lisp_Object string)
return dest + len;
}
+#if (defined HAVE___LSAN_IGNORE_OBJECT \
+ && defined HAVE_SANITIZER_LSAN_INTERFACE_H)
+# include <sanitizer/lsan_interface.h>
+#else
+/* Treat *P as a non-leak. */
+INLINE void
+__lsan_ignore_object (void const *p)
+{
+}
+#endif
+
extern void xputenv (const char *);
extern char *egetenv_internal (const char *, ptrdiff_t);
diff --git a/src/nsimage.m b/src/nsimage.m
index 07750de..966e704 100644
--- a/src/nsimage.m
+++ b/src/nsimage.m
@@ -199,6 +199,12 @@ ns_image_set_transform (void *img, double m[3][3])
[(EmacsImage *)img setTransform:m];
}
+void
+ns_image_set_smoothing (void *img, bool smooth)
+{
+ [(EmacsImage *)img setSmoothing:smooth];
+}
+
unsigned long
ns_get_pixel (void *img, int x, int y)
{
@@ -591,4 +597,10 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
[transform setTransformStruct:tm];
}
+- (void)setSmoothing: (BOOL) s
+{
+ smoothing = s;
+}
+
+
@end
diff --git a/src/nsterm.h b/src/nsterm.h
index 8d5371c..a511fef 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -640,6 +640,7 @@ typedef id instancetype;
unsigned long xbm_fg;
@public
NSAffineTransform *transform;
+ BOOL smoothing;
}
+ (instancetype)allocInitFromFile: (Lisp_Object)file;
- (void)dealloc;
@@ -658,6 +659,7 @@ typedef id instancetype;
- (Lisp_Object)getMetadata;
- (BOOL)setFrame: (unsigned int) index;
- (void)setTransform: (double[3][3]) m;
+- (void)setSmoothing: (BOOL)s;
@end
@@ -1200,6 +1202,7 @@ extern int ns_image_width (void *img);
extern int ns_image_height (void *img);
extern void ns_image_set_size (void *img, int width, int height);
extern void ns_image_set_transform (void *img, double m[3][3]);
+extern void ns_image_set_smoothing (void *img, bool smooth);
extern unsigned long ns_get_pixel (void *img, int x, int y);
extern void ns_put_pixel (void *img, int x, int y, unsigned long argb);
extern void ns_set_alpha (void *img, int x, int y, unsigned char a);
diff --git a/src/nsterm.m b/src/nsterm.m
index df7f716..572b859 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -4043,10 +4043,22 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
[doTransform concat];
+ /* Smoothing is the default, so if we don't want smoothing we
+ have to turn it off. */
+ if (! img->smoothing)
+ [[NSGraphicsContext currentContext]
+ setImageInterpolation:NSImageInterpolationNone];
+
[img drawInRect:ir fromRect:ir
operation:NSCompositingOperationSourceOver
fraction:1.0 respectFlipped:YES hints:nil];
+ /* Apparently image interpolation is not reset with
+ restoreGraphicsState, so we have to manually reset it. */
+ if (! img->smoothing)
+ [[NSGraphicsContext currentContext]
+ setImageInterpolation:NSImageInterpolationDefault];
+
[[NSGraphicsContext currentContext] restoreGraphicsState];
}
diff --git a/src/pdumper.c b/src/pdumper.c
index 28529d6..de9c06c 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -4785,15 +4785,15 @@ dump_mmap_contiguous_heap (struct dump_memory_map
*maps, int nr_maps,
Beware: the simple patch 2019-03-11T15:20:54Z!eggert@cs.ucla.edu
is worse, as it sometimes frees this storage twice. */
struct dump_memory_map_heap_control_block *cb = calloc (1, sizeof (*cb));
-
- char *mem;
if (!cb)
goto out;
+ __lsan_ignore_object (cb);
+
cb->refcount = 1;
cb->mem = malloc (total_size);
if (!cb->mem)
goto out;
- mem = cb->mem;
+ char *mem = cb->mem;
for (int i = 0; i < nr_maps; ++i)
{
struct dump_memory_map *map = &maps[i];
diff --git a/src/process.c b/src/process.c
index 6e5bcf3..15634e4 100644
--- a/src/process.c
+++ b/src/process.c
@@ -5491,6 +5491,10 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
else
{
+#ifdef HAVE_GNUTLS
+ int tls_nfds;
+ fd_set tls_available;
+#endif
/* Set the timeout for adaptive read buffering if any
process has non-zero read_output_skip and non-zero
read_output_delay, and we are not reading output for a
@@ -5560,7 +5564,36 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
#endif
-/* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */
+#ifdef HAVE_GNUTLS
+ /* GnuTLS buffers data internally. We need to check if some
+ data is available in the buffers manually before the select.
+ And if so, we need to skip the select which could block. */
+ FD_ZERO (&tls_available);
+ tls_nfds = 0;
+ for (channel = 0; channel < FD_SETSIZE; ++channel)
+ if (! NILP (chan_process[channel])
+ && FD_ISSET (channel, &Available))
+ {
+ struct Lisp_Process *p = XPROCESS (chan_process[channel]);
+ if (p
+ && p->gnutls_p && p->gnutls_state
+ && emacs_gnutls_record_check_pending (p->gnutls_state) > 0)
+ {
+ tls_nfds++;
+ eassert (p->infd == channel);
+ FD_SET (p->infd, &tls_available);
+ }
+ }
+ /* If wait_proc is somebody else, we have to wait in select
+ as usual. Otherwise, clobber the timeout. */
+ if (tls_nfds > 0
+ && (!wait_proc ||
+ (wait_proc->infd >= 0
+ && FD_ISSET (wait_proc->infd, &tls_available))))
+ timeout = make_timespec (0, 0);
+#endif
+
+ /* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */
#if defined HAVE_GLIB && !defined HAVE_NS
nfds = xg_select (max_desc + 1,
&Available, (check_write ? &Writeok : 0),
@@ -5578,59 +5611,21 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
#endif /* !HAVE_GLIB */
#ifdef HAVE_GNUTLS
- /* GnuTLS buffers data internally. In lowat mode it leaves
- some data in the TCP buffers so that select works, but
- with custom pull/push functions we need to check if some
- data is available in the buffers manually. */
- if (nfds == 0)
+ /* Merge tls_available into Available. */
+ if (tls_nfds > 0)
{
- fd_set tls_available;
- int set = 0;
-
- FD_ZERO (&tls_available);
- if (! wait_proc)
+ if (nfds == 0 || (nfds < 0 && errno == EINTR))
{
- /* We're not waiting on a specific process, so loop
- through all the channels and check for data.
- This is a workaround needed for some versions of
- the gnutls library -- 2.12.14 has been confirmed
- to need it. */
- for (channel = 0; channel < FD_SETSIZE; ++channel)
- if (! NILP (chan_process[channel]))
- {
- struct Lisp_Process *p =
- XPROCESS (chan_process[channel]);
- if (p && p->gnutls_p && p->gnutls_state
- && ((emacs_gnutls_record_check_pending
- (p->gnutls_state))
- > 0))
- {
- nfds++;
- eassert (p->infd == channel);
- FD_SET (p->infd, &tls_available);
- set++;
- }
- }
- }
- else
- {
- /* Check this specific channel. */
- if (wait_proc->gnutls_p /* Check for valid process. */
- && wait_proc->gnutls_state
- /* Do we have pending data? */
- && ((emacs_gnutls_record_check_pending
- (wait_proc->gnutls_state))
- > 0))
- {
- nfds = 1;
- eassert (0 <= wait_proc->infd);
- /* Set to Available. */
- FD_SET (wait_proc->infd, &tls_available);
- set++;
- }
+ /* Fast path, just copy. */
+ nfds = tls_nfds;
+ Available = tls_available;
}
- if (set)
- Available = tls_available;
+ else if (nfds > 0)
+ /* Slow path, merge one by one. Note: nfds does not need
+ to be accurate, just positive is enough. */
+ for (channel = 0; channel < FD_SETSIZE; ++channel)
+ if (FD_ISSET(channel, &tls_available))
+ FD_SET(channel, &Available);
}
#endif
}
diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h
deleted file mode 100644
index 22d49f2..0000000
--- a/src/ptr-bounds.h
+++ /dev/null
@@ -1,79 +0,0 @@
-/* Pointer bounds checking for GNU Emacs
-
-Copyright 2017-2020 Free Software Foundation, Inc.
-
-This file is part of GNU Emacs.
-
-GNU Emacs is free software: you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation, either version 3 of the License, or (at
-your option) any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
-
-/* Pointer bounds checking is a no-op unless running on hardware
- supporting Intel MPX (Intel Skylake or better). Also, it requires
- GCC 5 and Linux kernel 3.19, or later. Configure with
- CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with
- -fchkp-first-field-has-own-bounds thrown in.
-
- Although pointer bounds checking can help during debugging, it is
- disabled by default because it hurts performance significantly.
- The checking does not detect all pointer errors. For example, a
- dumped Emacs might not detect a bounds violation of a pointer that
- was created before Emacs was dumped. */
-
-#ifndef PTR_BOUNDS_H
-#define PTR_BOUNDS_H
-
-#include <stddef.h>
-
-/* When not checking pointer bounds, the following macros simply
- return their first argument. These macros return either void *, or
- the same type as their first argument. */
-
-INLINE_HEADER_BEGIN
-
-/* Return a copy of P, with bounds narrowed to [P, P + N). */
-#ifdef __CHKP__
-INLINE void *
-ptr_bounds_clip (void const *p, size_t n)
-{
- return __builtin___bnd_narrow_ptr_bounds (p, p, n);
-}
-#else
-# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p)
-#endif
-
-/* Return a copy of P, but with the bounds of Q. */
-#ifdef __CHKP__
-# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q)
-#else
-# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p)
-#endif
-
-/* Return a copy of P, but with infinite bounds.
- This is a loophole in pointer bounds checking. */
-#ifdef __CHKP__
-# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p)
-#else
-# define ptr_bounds_init(p) (p)
-#endif
-
-/* Return a copy of P, but with bounds [P, P + N).
- This is a loophole in pointer bounds checking. */
-#ifdef __CHKP__
-# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n)
-#else
-# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p)
-#endif
-
-INLINE_HEADER_END
-
-#endif /* PTR_BOUNDS_H */
diff --git a/src/regex-emacs.c b/src/regex-emacs.c
index 1ecbc74..c44cce9 100644
--- a/src/regex-emacs.c
+++ b/src/regex-emacs.c
@@ -29,10 +29,6 @@
#include <stdlib.h>
-#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H
-#include <sanitizer/lsan_interface.h>
-#endif
-
#include "character.h"
#include "buffer.h"
#include "syntax.h"
@@ -1761,9 +1757,7 @@ regex_compile (re_char *pattern, ptrdiff_t size,
/* Initialize the compile stack. */
compile_stack.stack = xmalloc (INIT_COMPILE_STACK_SIZE
* sizeof *compile_stack.stack);
-#ifdef HAVE___LSAN_IGNORE_OBJECT
__lsan_ignore_object (compile_stack.stack);
-#endif
compile_stack.size = INIT_COMPILE_STACK_SIZE;
compile_stack.avail = 0;
diff --git a/src/search.c b/src/search.c
index 7b74ff9..38c64ca 100644
--- a/src/search.c
+++ b/src/search.c
@@ -21,10 +21,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <config.h>
-#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H
-#include <sanitizer/lsan_interface.h>
-#endif
-
#include "lisp.h"
#include "character.h"
#include "buffer.h"
@@ -619,9 +615,7 @@ newline_cache_on_off (struct buffer *buf)
if (base_buf->newline_cache == 0)
{
base_buf->newline_cache = new_region_cache ();
-#ifdef HAVE___LSAN_IGNORE_OBJECT
__lsan_ignore_object (base_buf->newline_cache);
-#endif
}
}
return base_buf->newline_cache;
diff --git a/src/xdisp.c b/src/xdisp.c
index fc17014..4fe1c42 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -993,12 +993,12 @@ static void handle_line_prefix (struct it *);
static void handle_stop_backwards (struct it *, ptrdiff_t);
static void unwind_with_echo_area_buffer (Lisp_Object);
static Lisp_Object with_echo_area_buffer_unwind_data (struct window *);
-static bool current_message_1 (ptrdiff_t, Lisp_Object);
-static bool truncate_message_1 (ptrdiff_t, Lisp_Object);
+static bool current_message_1 (void *, Lisp_Object);
+static bool truncate_message_1 (void *, Lisp_Object);
static void set_message (Lisp_Object);
-static bool set_message_1 (ptrdiff_t, Lisp_Object);
-static bool display_echo_area_1 (ptrdiff_t, Lisp_Object);
-static bool resize_mini_window_1 (ptrdiff_t, Lisp_Object);
+static bool set_message_1 (void *, Lisp_Object);
+static bool display_echo_area_1 (void *, Lisp_Object);
+static bool resize_mini_window_1 (void *, Lisp_Object);
static void unwind_redisplay (void);
static void extend_face_to_end_of_line (struct it *);
static intmax_t message_log_check_duplicate (ptrdiff_t, ptrdiff_t);
@@ -11278,8 +11278,8 @@ ensure_echo_area_buffers (void)
static bool
with_echo_area_buffer (struct window *w, int which,
- bool (*fn) (ptrdiff_t, Lisp_Object),
- ptrdiff_t a1, Lisp_Object a2)
+ bool (*fn) (void *, Lisp_Object),
+ void *a1, Lisp_Object a2)
{
Lisp_Object buffer;
bool this_one, the_other, clear_buffer_p, rc;
@@ -11550,8 +11550,7 @@ display_echo_area (struct window *w)
window_height_changed_p
= with_echo_area_buffer (w, display_last_displayed_message_p,
- display_echo_area_1,
- (intptr_t) w, Qnil);
+ display_echo_area_1, w, Qnil);
if (no_message_p)
echo_area_buffer[i] = Qnil;
@@ -11568,10 +11567,9 @@ display_echo_area (struct window *w)
Value is true if height of W was changed. */
static bool
-display_echo_area_1 (ptrdiff_t a1, Lisp_Object a2)
+display_echo_area_1 (void *a1, Lisp_Object a2)
{
- intptr_t i1 = a1;
- struct window *w = (struct window *) i1;
+ struct window *w = a1;
Lisp_Object window;
struct text_pos start;
@@ -11612,7 +11610,7 @@ resize_echo_area_exactly (void)
struct window *w = XWINDOW (echo_area_window);
Lisp_Object resize_exactly = (minibuf_level == 0 ? Qt : Qnil);
bool resized_p = with_echo_area_buffer (w, 0, resize_mini_window_1,
- (intptr_t) w, resize_exactly);
+ w, resize_exactly);
if (resized_p)
{
windows_or_buffers_changed = 42;
@@ -11630,10 +11628,9 @@ resize_echo_area_exactly (void)
returns. */
static bool
-resize_mini_window_1 (ptrdiff_t a1, Lisp_Object exactly)
+resize_mini_window_1 (void *a1, Lisp_Object exactly)
{
- intptr_t i1 = a1;
- return resize_mini_window ((struct window *) i1, !NILP (exactly));
+ return resize_mini_window (a1, !NILP (exactly));
}
@@ -11769,8 +11766,7 @@ current_message (void)
msg = Qnil;
else
{
- with_echo_area_buffer (0, 0, current_message_1,
- (intptr_t) &msg, Qnil);
+ with_echo_area_buffer (0, 0, current_message_1, &msg, Qnil);
if (NILP (msg))
echo_area_buffer[0] = Qnil;
}
@@ -11780,10 +11776,9 @@ current_message (void)
static bool
-current_message_1 (ptrdiff_t a1, Lisp_Object a2)
+current_message_1 (void *a1, Lisp_Object a2)
{
- intptr_t i1 = a1;
- Lisp_Object *msg = (Lisp_Object *) i1;
+ Lisp_Object *msg = a1;
if (Z > BEG)
*msg = make_buffer_string (BEG, Z, true);
@@ -11857,7 +11852,8 @@ truncate_echo_area (ptrdiff_t nchars)
just an informative message; if the frame hasn't really been
initialized yet, just toss it. */
if (sf->glyphs_initialized_p)
- with_echo_area_buffer (0, 0, truncate_message_1, nchars, Qnil);
+ with_echo_area_buffer (0, 0, truncate_message_1,
+ (void *) (intptr_t) nchars, Qnil);
}
}
@@ -11866,8 +11862,9 @@ truncate_echo_area (ptrdiff_t nchars)
message to at most NCHARS characters. */
static bool
-truncate_message_1 (ptrdiff_t nchars, Lisp_Object a2)
+truncate_message_1 (void *a1, Lisp_Object a2)
{
+ intptr_t nchars = (intptr_t) a1;
if (BEG + nchars < Z)
del_range (BEG + nchars, Z);
if (Z == BEG)
@@ -11919,7 +11916,7 @@ set_message (Lisp_Object string)
This function is called with the echo area buffer being current. */
static bool
-set_message_1 (ptrdiff_t a1, Lisp_Object string)
+set_message_1 (void *a1, Lisp_Object string)
{
eassert (STRINGP (string));
@@ -19223,18 +19220,19 @@ try_window (Lisp_Object window, struct text_pos pos,
int flags)
&& !MINI_WINDOW_P (w))
{
int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS);
+ if (window_wants_header_line (w))
+ this_scroll_margin += CURRENT_HEADER_LINE_HEIGHT (w);
start_display (&it, w, pos);
if ((w->cursor.y >= 0 /* not vscrolled */
&& w->cursor.y < this_scroll_margin
- && CHARPOS (pos) > BEGV
- && it_charpos < ZV)
+ && CHARPOS (pos) > BEGV)
/* rms: considering make_cursor_line_fully_visible_p here
seems to give wrong results. We don't want to recenter
when the last line is partly visible, we want to allow
that case to be handled in the usual way. */
- || w->cursor.y > (it.last_visible_y - partial_line_height (&it)
- - this_scroll_margin - 1))
+ || w->cursor.y > (it.last_visible_y - partial_line_height (&it)
+ - this_scroll_margin - 1))
{
w->cursor.vpos = -1;
clear_glyph_matrix (w->desired_matrix);
diff --git a/src/xfns.c b/src/xfns.c
index 2ab5080..09dcbbf 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -2652,7 +2652,7 @@ create_frame_xic (struct frame *f)
goto out;
xim = FRAME_X_XIM (f);
- if (!xim)
+ if (!xim || ! FRAME_X_XIM_STYLES(f))
goto out;
/* Determine XIC style. */
diff --git a/test/README b/test/README
index 1f69f71..fe05b54 100644
--- a/test/README
+++ b/test/README
@@ -64,6 +64,11 @@ protect against "make" variable expansion):
make <filename> SELECTOR='"foo$$"'
+In case you want to use the symbol name of a test as selector, you can
+use it directly:
+
+ make <filename> SELECTOR='test-foo-remote'
+
Note that although the test files are always compiled (unless they set
no-byte-compile), the source files will be run when expensive or
unstable tests are involved, to give nicer backtraces. To run the
diff --git a/test/data/mml-sec/.gpg-v21-migrated
b/test/data/mml-sec/.gpg-v21-migrated
new file mode 100644
index 0000000..e69de29
diff --git a/test/data/mml-sec/gpg-agent.conf b/test/data/mml-sec/gpg-agent.conf
new file mode 100644
index 0000000..2019299
--- /dev/null
+++ b/test/data/mml-sec/gpg-agent.conf
@@ -0,0 +1,5 @@
+# pinentry-program /usr/bin/pinentry-gtk-2
+
+# verbose
+# log-file /tmp/gpg-agent.log
+# debug-all
diff --git
a/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key
b/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key
new file mode 100644
index 0000000..58fd0b5
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key
b/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key
new file mode 100644
index 0000000..62f4ab2
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key
b/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key
new file mode 100644
index 0000000..2a8ce13
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key
b/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key
new file mode 100644
index 0000000..9f8de71
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key
b/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key
new file mode 100644
index 0000000..6e4a4e5
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key
b/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key
new file mode 100644
index 0000000..cff58ed
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key
b/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key
new file mode 100644
index 0000000..14af866
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key
b/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key
new file mode 100644
index 0000000..207a723
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key
b/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key
new file mode 100644
index 0000000..85ca78d
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key
b/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key
new file mode 100644
index 0000000..79f3cd2
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key
b/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key
new file mode 100644
index 0000000..776ddf7
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key
b/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key
new file mode 100644
index 0000000..2b464f0
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key
b/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key
new file mode 100644
index 0000000..28a0766
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key
b/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key
new file mode 100644
index 0000000..1376596
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key
b/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key
new file mode 100644
index 0000000..c99824c
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key
b/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key
new file mode 100644
index 0000000..49c2dc5
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key
b/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key
new file mode 100644
index 0000000..ca12840
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key
b/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key
new file mode 100644
index 0000000..3f14b40
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key
b/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key
new file mode 100644
index 0000000..06adc06
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key
b/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key
new file mode 100644
index 0000000..cf9a60d
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key
b/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key
new file mode 100644
index 0000000..0ed3517
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key
b/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key
new file mode 100644
index 0000000..090059d
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key
b/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key
new file mode 100644
index 0000000..9061f67
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key
b/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key
new file mode 100644
index 0000000..89f6013
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key
b/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key
new file mode 100644
index 0000000..41dac37
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key
b/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key
new file mode 100644
index 0000000..5df7b4a
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key
differ
diff --git
a/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key
b/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key
new file mode 100644
index 0000000..03daf80
Binary files /dev/null and
b/test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key
differ
diff --git a/test/data/mml-sec/pubring.gpg b/test/data/mml-sec/pubring.gpg
new file mode 100644
index 0000000..6bd1699
Binary files /dev/null and b/test/data/mml-sec/pubring.gpg differ
diff --git a/test/data/mml-sec/pubring.kbx b/test/data/mml-sec/pubring.kbx
new file mode 100644
index 0000000..399a041
Binary files /dev/null and b/test/data/mml-sec/pubring.kbx differ
diff --git a/test/data/mml-sec/secring.gpg b/test/data/mml-sec/secring.gpg
new file mode 100644
index 0000000..b323c07
Binary files /dev/null and b/test/data/mml-sec/secring.gpg differ
diff --git a/test/data/mml-sec/trustdb.gpg b/test/data/mml-sec/trustdb.gpg
new file mode 100644
index 0000000..09ebd8d
Binary files /dev/null and b/test/data/mml-sec/trustdb.gpg differ
diff --git a/test/data/mml-sec/trustlist.txt b/test/data/mml-sec/trustlist.txt
new file mode 100644
index 0000000..f886572
--- /dev/null
+++ b/test/data/mml-sec/trustlist.txt
@@ -0,0 +1,26 @@
+# This is the list of trusted keys. Comment lines, like this one, as
+# well as empty lines are ignored. Lines have a length limit but this
+# is not a serious limitation as the format of the entries is fixed and
+# checked by gpg-agent. A non-comment line starts with optional white
+# space, followed by the SHA-1 fingerpint in hex, followed by a flag
+# which may be one of 'P', 'S' or '*' and optionally followed by a list of
+# other flags. The fingerprint may be prefixed with a '!' to mark the
+# key as not trusted. You should give the gpg-agent a HUP or run the
+# command "gpgconf --reload gpg-agent" after changing this file.
+
+
+# Include the default trust list
+include-default
+
+
+# CN=No Expiry
+D0:6A:A1:18:65:3C:C3:8E:9D:0C:AF:56:ED:7A:21:35:E1:58:21:77 S relax
+
+# CN=Second Key Pair
+0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 S relax
+
+# CN=No Expiry two UIDs
+D4:CA:78:E1:47:0B:9F:C2:AE:45:D7:84:64:9B:8C:E6:4E:BB:32:0C S relax
+
+# CN=Different subkeys
+4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC S relax
diff --git a/test/lisp/calendar/time-date-tests.el
b/test/lisp/calendar/time-date-tests.el
index 3eecc67..fe1460c 100644
--- a/test/lisp/calendar/time-date-tests.el
+++ b/test/lisp/calendar/time-date-tests.el
@@ -109,4 +109,18 @@
(ert-deftest test-time-since ()
(should (time-equal-p 0 (time-since nil))))
+(ert-deftest test-time-decoded-period ()
+ (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil))
+ 3600))
+
+ (should (equal (decoded-time-period '(1 0 0 0 0 0 nil nil nil)) 1))
+ (should (equal (decoded-time-period '(0 1 0 0 0 0 nil nil nil)) 60))
+ (should (equal (decoded-time-period '(0 0 1 0 0 0 nil nil nil)) 3600))
+ (should (equal (decoded-time-period '(0 0 0 1 0 0 nil nil nil)) 86400))
+ (should (equal (decoded-time-period '(0 0 0 0 1 0 nil nil nil)) 2592000))
+ (should (equal (decoded-time-period '(0 0 0 0 0 1 nil nil nil)) 31536000))
+
+ (should (equal (decoded-time-period '((135 . 10) 0 0 0 0 0 nil nil nil))
+ 13.5)))
+
;;; time-date-tests.el ends here
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index c235dd4..8949143 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -47,6 +47,11 @@
(let ((a 1.0)) (/ 3 a 2))
(let ((a most-positive-fixnum) (b 2.0)) (* a 2 b))
(let ((a 3) (b 2)) (/ a b 1.0))
+ (let ((a -0.0)) (+ a))
+ (let ((a -0.0)) (- a))
+ (let ((a -0.0)) (* a))
+ (let ((a -0.0)) (min a))
+ (let ((a -0.0)) (max a))
(/ 3 -1)
(+ 4 3 2 1)
(+ 4 3 2.0 1)
diff --git a/test/lisp/emacs-lisp/cconv-tests.el
b/test/lisp/emacs-lisp/cconv-tests.el
index c8d4654..0ea9742 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -20,6 +20,166 @@
;;; Commentary:
(require 'ert)
+(require 'cl-lib)
+
+(ert-deftest cconv-tests-lambda-:documentation ()
+ "Docstring for lambda can be specified with :documentation."
+ (let ((fun (lambda ()
+ (:documentation (concat "lambda" " documentation"))
+ 'lambda-result)))
+ (should (string= (documentation fun) "lambda documentation"))
+ (should (eq (funcall fun) 'lambda-result))))
+
+(ert-deftest cconv-tests-pcase-lambda-:documentation ()
+ "Docstring for pcase-lambda can be specified with :documentation."
+ (let ((fun (pcase-lambda (`(,a ,b))
+ (:documentation (concat "pcase-lambda" " documentation"))
+ (list b a))))
+ (should (string= (documentation fun) "pcase-lambda documentation"))
+ (should (equal '(2 1) (funcall fun '(1 2))))))
+
+(defun cconv-tests-defun ()
+ (:documentation (concat "defun" " documentation"))
+ 'defun-result)
+(ert-deftest cconv-tests-defun-:documentation ()
+ "Docstring for defun can be specified with :documentation."
+ (should (string= (documentation 'cconv-tests-defun)
+ "defun documentation"))
+ (should (eq (cconv-tests-defun) 'defun-result)))
+
+(cl-defun cconv-tests-cl-defun ()
+ (:documentation (concat "cl-defun" " documentation"))
+ 'cl-defun-result)
+(ert-deftest cconv-tests-cl-defun-:documentation ()
+ "Docstring for cl-defun can be specified with :documentation."
+ (should (string= (documentation 'cconv-tests-cl-defun)
+ "cl-defun documentation"))
+ (should (eq (cconv-tests-cl-defun) 'cl-defun-result)))
+
+;; FIXME: The byte-complier croaks on this. See Bug#28557.
+;; (defmacro cconv-tests-defmacro ()
+;; (:documentation (concat "defmacro" " documentation"))
+;; '(quote defmacro-result))
+;; (ert-deftest cconv-tests-defmacro-:documentation ()
+;; "Docstring for defmacro can be specified with :documentation."
+;; (should (string= (documentation 'cconv-tests-defmacro)
+;; "defmacro documentation"))
+;; (should (eq (cconv-tests-defmacro) 'defmacro-result)))
+
+;; FIXME: The byte-complier croaks on this. See Bug#28557.
+;; (cl-defmacro cconv-tests-cl-defmacro ()
+;; (:documentation (concat "cl-defmacro" " documentation"))
+;; '(quote cl-defmacro-result))
+;; (ert-deftest cconv-tests-cl-defmacro-:documentation ()
+;; "Docstring for cl-defmacro can be specified with :documentation."
+;; (should (string= (documentation 'cconv-tests-cl-defmacro)
+;; "cl-defmacro documentation"))
+;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result)))
+
+(cl-iter-defun cconv-tests-cl-iter-defun ()
+ (:documentation (concat "cl-iter-defun" " documentation"))
+ (iter-yield 'cl-iter-defun-result))
+(ert-deftest cconv-tests-cl-iter-defun-:documentation ()
+ "Docstring for cl-iter-defun can be specified with :documentation."
+ ;; FIXME: See Bug#28557.
+ :tags '(:unstable)
+ :expected-result :failed
+ (should (string= (documentation 'cconv-tests-cl-iter-defun)
+ "cl-iter-defun documentation"))
+ (should (eq (iter-next (cconv-tests-cl-iter-defun))
+ 'cl-iter-defun-result)))
+
+(iter-defun cconv-tests-iter-defun ()
+ (:documentation (concat "iter-defun" " documentation"))
+ (iter-yield 'iter-defun-result))
+(ert-deftest cconv-tests-iter-defun-:documentation ()
+ "Docstring for iter-defun can be specified with :documentation."
+ ;; FIXME: See Bug#28557.
+ :tags '(:unstable)
+ :expected-result :failed
+ (should (string= (documentation 'cconv-tests-iter-defun)
+ "iter-defun documentation"))
+ (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result)))
+
+(ert-deftest cconv-tests-iter-lambda-:documentation ()
+ "Docstring for iter-lambda can be specified with :documentation."
+ ;; FIXME: See Bug#28557.
+ :expected-result :failed
+ (let ((iter-fun
+ (iter-lambda ()
+ (:documentation (concat "iter-lambda" " documentation"))
+ (iter-yield 'iter-lambda-result))))
+ (should (string= (documentation iter-fun) "iter-lambda documentation"))
+ (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result))))
+
+(ert-deftest cconv-tests-cl-function-:documentation ()
+ "Docstring for cl-function can be specified with :documentation."
+ ;; FIXME: See Bug#28557.
+ :expected-result :failed
+ (let ((fun (cl-function (lambda (&key arg)
+ (:documentation (concat "cl-function"
+ " documentation"))
+ (list arg 'cl-function-result)))))
+ (should (string= (documentation fun) "cl-function documentation"))
+ (should (equal (funcall fun :arg t) '(t cl-function-result)))))
+
+(ert-deftest cconv-tests-function-:documentation ()
+ "Docstring for lambda inside function can be specified with :documentation."
+ (let ((fun #'(lambda (arg)
+ (:documentation (concat "function" " documentation"))
+ (list arg 'function-result))))
+ (should (string= (documentation fun) "function documentation"))
+ (should (equal (funcall fun t) '(t function-result)))))
+
+(fmakunbound 'cconv-tests-cl-defgeneric)
+(setplist 'cconv-tests-cl-defgeneric nil)
+(cl-defgeneric cconv-tests-cl-defgeneric (n)
+ (:documentation (concat "cl-defgeneric" " documentation")))
+(cl-defmethod cconv-tests-cl-defgeneric ((n integer))
+ (:documentation (concat "cl-defmethod" " documentation"))
+ (+ 1 n))
+(ert-deftest cconv-tests-cl-defgeneric-:documentation ()
+ "Docstring for cl-defgeneric can be specified with :documentation."
+ ;; FIXME: See Bug#28557.
+ :expected-result :failed
+ (let ((descr (describe-function 'cconv-tests-cl-defgeneric)))
+ (set-text-properties 0 (length descr) nil descr)
+ (should (string-match-p "cl-defgeneric documentation" descr))
+ (should (string-match-p "cl-defmethod documentation" descr)))
+ (should (= 11 (cconv-tests-cl-defgeneric 10))))
+
+(fmakunbound 'cconv-tests-cl-defgeneric-literal)
+(setplist 'cconv-tests-cl-defgeneric-literal nil)
+(cl-defgeneric cconv-tests-cl-defgeneric-literal (n)
+ (:documentation "cl-defgeneric-literal documentation"))
+(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer))
+ (:documentation "cl-defmethod-literal documentation")
+ (+ 1 n))
+(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation ()
+ "Docstring for cl-defgeneric can be specified with :documentation."
+ (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal)))
+ (set-text-properties 0 (length descr) nil descr)
+ (should (string-match-p "cl-defgeneric-literal documentation" descr))
+ (should (string-match-p "cl-defmethod-literal documentation" descr)))
+ (should (= 11 (cconv-tests-cl-defgeneric-literal 10))))
+
+(defsubst cconv-tests-defsubst ()
+ (:documentation (concat "defsubst" " documentation"))
+ 'defsubst-result)
+(ert-deftest cconv-tests-defsubst-:documentation ()
+ "Docstring for defsubst can be specified with :documentation."
+ (should (string= (documentation 'cconv-tests-defsubst)
+ "defsubst documentation"))
+ (should (eq (cconv-tests-defsubst) 'defsubst-result)))
+
+(cl-defsubst cconv-tests-cl-defsubst ()
+ (:documentation (concat "cl-defsubst" " documentation"))
+ 'cl-defsubst-result)
+(ert-deftest cconv-tests-cl-defsubst-:documentation ()
+ "Docstring for cl-defsubst can be specified with :documentation."
+ (should (string= (documentation 'cconv-tests-cl-defsubst)
+ "cl-defsubst documentation"))
+ (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result)))
(ert-deftest cconv-convert-lambda-lifted ()
"Bug#30872."
diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el
b/test/lisp/emacs-lisp/cl-generic-tests.el
index 51c9884..5aa5878 100644
--- a/test/lisp/emacs-lisp/cl-generic-tests.el
+++ b/test/lisp/emacs-lisp/cl-generic-tests.el
@@ -24,6 +24,7 @@
;;; Code:
(require 'cl-generic)
+(require 'edebug)
;; Don't indirectly require `cl-lib' at run-time.
(eval-when-compile (require 'ert))
@@ -249,5 +250,42 @@
(should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic))
(should-not (cl--generic-method-files
'cl-generic-tests--generic-without-methods)))
+(ert-deftest cl-defgeneric/edebug/method ()
+ "Check that `:method' forms in `cl-defgeneric' create unique
+Edebug symbols (Bug#42672)."
+ (with-temp-buffer
+ (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_)
+ (:method ((_ number)) 1)
+ (:method ((_ string)) 2)
+ (:method :around ((_ number)) 3))
+ (cl-defgeneric cl-defgeneric/edebug/method/2 (_)
+ (:method ((_ number)) 3))))
+ (print form (current-buffer)))
+ (let* ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop)
+ (instrumented-names ())
+ (edebug-new-definition-function
+ (lambda (name)
+ (when (memq name instrumented-names)
+ (error "Duplicate definition of `%s'" name))
+ (push name instrumented-names)
+ (edebug-new-definition name)))
+ ;; Make generated symbols reproducible.
+ (gensym-counter 10000))
+ (eval-buffer)
+ (should (equal
+ (reverse instrumented-names)
+ ;; The generic function definitions come after the
+ ;; method definitions because their body ends later.
+ ;; FIXME: We'd rather have names such as
+ ;; `cl-defgeneric/edebug/method/1 ((_ number))', but
+ ;; that requires further changes to Edebug.
+ (list (intern "cl-generic-:method@10000 ((_ number))")
+ (intern "cl-generic-:method@10001 ((_ string))")
+ (intern "cl-generic-:method@10002 :around ((_ number))")
+ 'cl-defgeneric/edebug/method/1
+ (intern "cl-generic-:method@10003 ((_ number))")
+ 'cl-defgeneric/edebug/method/2))))))
+
(provide 'cl-generic-tests)
;;; cl-generic-tests.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el
b/test/lisp/emacs-lisp/edebug-tests.el
index 41811c9..04a7b2f 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -938,5 +938,99 @@ test and possibly others should be updated."
"g"
(should (equal edebug-tests-@-result '(0 1))))))
+(ert-deftest edebug-cl-defmethod-qualifier ()
+ "Check that secondary `cl-defmethod' forms don't stomp over
+primary ones (Bug#42671)."
+ (with-temp-buffer
+ (let* ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop)
+ (defined-symbols ())
+ (edebug-new-definition-function
+ (lambda (def-name)
+ (push def-name defined-symbols)
+ (edebug-new-definition def-name))))
+ (dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number)))
+ (cl-defmethod edebug-cl-defmethod-qualifier
+ :around ((_ number)))))
+ (print form (current-buffer)))
+ (eval-buffer)
+ (should
+ (equal
+ defined-symbols
+ (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))")
+ (intern "edebug-cl-defmethod-qualifier ((_ number))")))))))
+
+(ert-deftest edebug-tests-cl-flet ()
+ "Check that Edebug can instrument `cl-flet' forms without name
+clashes (Bug#41853)."
+ (with-temp-buffer
+ (dolist (form '((defun edebug-tests-cl-flet-1 ()
+ (cl-flet ((inner () 0)) (message "Hi"))
+ (cl-flet ((inner () 1)) (inner)))
+ (defun edebug-tests-cl-flet-2 ()
+ (cl-flet ((inner () 2)) (inner)))))
+ (print form (current-buffer)))
+ (let* ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop)
+ (instrumented-names ())
+ (edebug-new-definition-function
+ (lambda (name)
+ (when (memq name instrumented-names)
+ (error "Duplicate definition of `%s'" name))
+ (push name instrumented-names)
+ (edebug-new-definition name)))
+ ;; Make generated symbols reproducible.
+ (gensym-counter 10000))
+ (eval-buffer)
+ (should (equal (reverse instrumented-names)
+ ;; The outer definitions come after the inner
+ ;; ones because their body ends later.
+ ;; FIXME: There are twice as many inner
+ ;; definitions as expected due to Bug#41988.
+ ;; Once that bug is fixed, remove the duplicates.
+ ;; FIXME: We'd rather have names such as
+ ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000',
+ ;; but that requires further changes to Edebug.
+ '(inner@cl-flet@10000
+ inner@cl-flet@10001
+ inner@cl-flet@10002
+ inner@cl-flet@10003
+ edebug-tests-cl-flet-1
+ inner@cl-flet@10004
+ inner@cl-flet@10005
+ edebug-tests-cl-flet-2))))))
+
+(ert-deftest edebug-tests-duplicate-symbol-backtrack ()
+ "Check that Edebug doesn't create duplicate symbols when
+backtracking (Bug#42701)."
+ (with-temp-buffer
+ (dolist (form '((require 'subr-x)
+ (defun edebug-tests-duplicate-symbol-backtrack ()
+ (if-let (x (funcall (lambda (y) 1) 2)) 3 4))))
+ (print form (current-buffer)))
+ (let* ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop)
+ (instrumented-names ())
+ (edebug-new-definition-function
+ (lambda (name)
+ (when (memq name instrumented-names)
+ (error "Duplicate definition of `%s'" name))
+ (push name instrumented-names)
+ (edebug-new-definition name)))
+ ;; Make generated symbols reproducible.
+ (gensym-counter 10000))
+ (eval-buffer)
+ ;; The anonymous symbols are uninterned. Use their names so we
+ ;; can perform the assertion. The names should still be unique.
+ (should (equal (mapcar #'symbol-name (reverse instrumented-names))
+ ;; The outer definition comes after the inner
+ ;; ones because its body ends later.
+ ;; FIXME: There are twice as many inner
+ ;; definitions as expected due to Bug#42701.
+ ;; Once that bug is fixed, remove the duplicates.
+ '("edebug-anon10000"
+ "edebug-anon10001"
+ "edebug-tests-duplicate-symbol-backtrack"))))))
+
(provide 'edebug-tests)
;;; edebug-tests.el ends here
diff --git a/test/lisp/emacs-lisp/generator-tests.el
b/test/lisp/emacs-lisp/generator-tests.el
index 9b1a573..72eee07 100644
--- a/test/lisp/emacs-lisp/generator-tests.el
+++ b/test/lisp/emacs-lisp/generator-tests.el
@@ -22,6 +22,10 @@
;;; Commentary:
+;; Unit tests for generator.el.
+
+;;; Code:
+
(require 'generator)
(require 'ert)
(require 'cl-lib)
diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el
b/test/lisp/emacs-lisp/hierarchy-tests.el
new file mode 100644
index 0000000..23cfc79
--- /dev/null
+++ b/test/lisp/emacs-lisp/hierarchy-tests.el
@@ -0,0 +1,556 @@
+;;; hierarchy-tests.el --- Tests for hierarchy.el
+
+;; Copyright (C) 2017-2019 Damien Cassou
+
+;; Author: Damien Cassou <damien@cassou.me>
+;; Maintainer: emacs-devel@gnu.org
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for hierarchy.el
+
+;;; Code:
+
+(require 'ert)
+(require 'hierarchy)
+
+(defun hierarchy-animals ()
+ "Create a sorted animal hierarchy."
+ (let ((parentfn (lambda (item) (cl-case item
+ (dove 'bird)
+ (pigeon 'bird)
+ (bird 'animal)
+ (dolphin 'animal)
+ (cow 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'dove parentfn)
+ (hierarchy-add-tree hierarchy 'pigeon parentfn)
+ (hierarchy-add-tree hierarchy 'dolphin parentfn)
+ (hierarchy-add-tree hierarchy 'cow parentfn)
+ (hierarchy-sort hierarchy)
+ hierarchy))
+
+(ert-deftest hierarchy-add-one-root ()
+ (let ((parentfn (lambda (_) nil))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'animal parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))))
+
+(ert-deftest hierarchy-add-one-item-with-parent ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'bird parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
+
+(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (dove 'bird)
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'dove parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove)))))
+
+(ert-deftest hierarchy-add-same-root-twice ()
+ (let ((parentfn (lambda (_) nil))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'animal parentfn)
+ (hierarchy-add-tree hierarchy 'animal parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))))
+
+(ert-deftest hierarchy-add-same-child-twice ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'bird parentfn)
+ (hierarchy-add-tree hierarchy 'bird parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
+
+(ert-deftest hierarchy-add-item-and-its-parent ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'bird parentfn)
+ (hierarchy-add-tree hierarchy 'animal parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
+
+(ert-deftest hierarchy-add-item-and-its-child ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'animal parentfn)
+ (hierarchy-add-tree hierarchy 'bird parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
+
+(ert-deftest hierarchy-add-two-items-sharing-parent ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (dove 'bird)
+ (pigeon 'bird))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'dove parentfn)
+ (hierarchy-add-tree hierarchy 'pigeon parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(bird)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
+
+(ert-deftest hierarchy-add-two-hierarchies ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (dove 'bird)
+ (circle 'shape))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'dove parentfn)
+ (hierarchy-add-tree hierarchy 'circle parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(bird shape)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove)))
+ (should (equal (hierarchy-children hierarchy 'shape) '(circle)))))
+
+(ert-deftest hierarchy-add-with-childrenfn ()
+ (let ((childrenfn (lambda (item)
+ (cl-case item
+ (animal '(bird))
+ (bird '(dove pigeon)))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'animal nil childrenfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
+
+(ert-deftest hierarchy-add-with-parentfn-and-childrenfn ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal)
+ (animal 'life-form))))
+ (childrenfn (lambda (item)
+ (cl-case item
+ (bird '(dove pigeon))
+ (pigeon '(ashy-wood-pigeon)))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'bird parentfn childrenfn)
+ (should (equal (hierarchy-roots hierarchy) '(life-form)))
+ (should (equal (hierarchy-children hierarchy 'life-form) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))
+ (should (equal (hierarchy-children hierarchy 'pigeon)
'(ashy-wood-pigeon)))))
+
+(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn ()
+ (let* ((parentfn (lambda (item)
+ (cl-case item
+ (dove 'bird)
+ (bird 'animal))))
+ (childrenfn (lambda (item)
+ (cl-case item
+ (animal '(bird))
+ (bird '(dove)))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'bird parentfn childrenfn)
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove)))))
+
+(ert-deftest hierarchy-add-trees ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (dove 'bird)
+ (pigeon 'bird)
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-trees hierarchy '(dove pigeon) parentfn)
+ (should (equal (hierarchy-roots hierarchy) '(animal)))
+ (should (equal (hierarchy-children hierarchy 'animal) '(bird)))
+ (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
+
+(ert-deftest hierarchy-from-list ()
+ (let ((hierarchy (hierarchy-from-list
+ '(animal (bird (dove)
+ (pigeon))
+ (cow)
+ (dolphin)))))
+ (hierarchy-sort hierarchy (lambda (item1 item2)
+ (string< (car item1)
+ (car item2))))
+ (should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name
(car item))))
+ "animal\n bird\n dove\n pigeon\n cow\n
dolphin\n"))))
+
+(ert-deftest hierarchy-from-list-with-duplicates ()
+ (let ((hierarchy (hierarchy-from-list
+ '(a (b) (b))
+ t)))
+ (hierarchy-sort hierarchy (lambda (item1 item2)
+ ;; sort by ID
+ (< (car item1) (car item2))))
+ (should (equal (hierarchy-length hierarchy) 3))
+ (should (equal (hierarchy-to-string
+ hierarchy
+ (lambda (item)
+ (format "%s(%s)"
+ (cadr item)
+ (car item))))
+ "a(1)\n b(2)\n b(3)\n"))))
+
+(ert-deftest hierarchy-from-list-with-childrenfn ()
+ (let ((hierarchy (hierarchy-from-list
+ "abc"
+ nil
+ (lambda (item)
+ (when (string= item "abc")
+ (split-string item "" t))))))
+ (hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2)))
+ (should (equal (hierarchy-length hierarchy) 4))
+ (should (equal (hierarchy-to-string hierarchy)
+ "abc\n a\n b\n c\n"))))
+
+(ert-deftest hierarchy-add-relation-check-error-when-different-parent ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'bird parentfn)
+ (should-error
+ (hierarchy--add-relation hierarchy 'bird 'cow #'identity))))
+
+(ert-deftest hierarchy-empty-p-return-non-nil-for-empty ()
+ (should (hierarchy-empty-p (hierarchy-new))))
+
+(ert-deftest hierarchy-empty-p-return-nil-for-non-empty ()
+ (should-not (hierarchy-empty-p (hierarchy-animals))))
+
+(ert-deftest hierarchy-length-of-empty-is-0 ()
+ (should (equal (hierarchy-length (hierarchy-new)) 0)))
+
+(ert-deftest hierarchy-length-of-non-empty-counts-items ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal)
+ (dove 'bird)
+ (pigeon 'bird))))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'dove parentfn)
+ (hierarchy-add-tree hierarchy 'pigeon parentfn)
+ (should (equal (hierarchy-length hierarchy) 4))))
+
+(ert-deftest hierarchy-has-root ()
+ (let ((parentfn (lambda (item)
+ (cl-case item
+ (bird 'animal)
+ (dove 'bird)
+ (pigeon 'bird))))
+ (hierarchy (hierarchy-new)))
+ (should-not (hierarchy-has-root hierarchy 'animal))
+ (should-not (hierarchy-has-root hierarchy 'bird))
+ (hierarchy-add-tree hierarchy 'dove parentfn)
+ (hierarchy-add-tree hierarchy 'pigeon parentfn)
+ (should (hierarchy-has-root hierarchy 'animal))
+ (should-not (hierarchy-has-root hierarchy 'bird))))
+
+(ert-deftest hierarchy-leafs ()
+ (let ((animals (hierarchy-animals)))
+ (should (equal (hierarchy-leafs animals)
+ '(dove pigeon dolphin cow)))))
+
+(ert-deftest hierarchy-leafs-includes-lonely-roots ()
+ (let ((parentfn (lambda (item) nil))
+ (hierarchy (hierarchy-new)))
+ (hierarchy-add-tree hierarchy 'foo parentfn)
+ (should (equal (hierarchy-leafs hierarchy)
+ '(foo)))))
+
+(ert-deftest hierarchy-leafs-of-node ()
+ (let ((animals (hierarchy-animals)))
+ (should (equal (hierarchy-leafs animals 'cow) '()))
+ (should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin
cow)))
+ (should (equal (hierarchy-leafs animals 'bird) '(dove pigeon)))
+ (should (equal (hierarchy-leafs animals 'dove) '()))))
+
+(ert-deftest hierarchy-child-p ()
+ (let ((animals (hierarchy-animals)))
+ (should (hierarchy-child-p animals 'dove 'bird))
+ (should (hierarchy-child-p animals 'bird 'animal))
+ (should (hierarchy-child-p animals 'cow 'animal))
+ (should-not (hierarchy-child-p animals 'cow 'bird))
+ (should-not (hierarchy-child-p animals 'bird 'cow))
+ (should-not (hierarchy-child-p animals 'animal 'dove))
+ (should-not (hierarchy-child-p animals 'animal 'bird))))
+
+(ert-deftest hierarchy-descendant ()
+ (let ((animals (hierarchy-animals)))
+ (should (hierarchy-descendant-p animals 'dove 'animal))
+ (should (hierarchy-descendant-p animals 'dove 'bird))
+ (should (hierarchy-descendant-p animals 'bird 'animal))
+ (should (hierarchy-descendant-p animals 'cow 'animal))
+ (should-not (hierarchy-descendant-p animals 'cow 'bird))
+ (should-not (hierarchy-descendant-p animals 'bird 'cow))
+ (should-not (hierarchy-descendant-p animals 'animal 'dove))
+ (should-not (hierarchy-descendant-p animals 'animal 'bird))))
+
+(ert-deftest hierarchy-descendant-if-not-same ()
+ (let ((animals (hierarchy-animals)))
+ (should-not (hierarchy-descendant-p animals 'cow 'cow))
+ (should-not (hierarchy-descendant-p animals 'dove 'dove))
+ (should-not (hierarchy-descendant-p animals 'bird 'bird))
+ (should-not (hierarchy-descendant-p animals 'animal 'animal))))
+
+;; keywords supported: :test :key
+(ert-deftest hierarchy--set-equal ()
+ (should (hierarchy--set-equal '(1 2 3) '(1 2 3)))
+ (should (hierarchy--set-equal '(1 2 3) '(3 2 1)))
+ (should (hierarchy--set-equal '(3 2 1) '(1 2 3)))
+ (should-not (hierarchy--set-equal '(2 3) '(3 2 1)))
+ (should-not (hierarchy--set-equal '(1 2 3) '(2 3)))
+ (should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq))
+ (should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal))
+ (should-not (hierarchy--set-equal '(1 2) '(-1 -2)))
+ (should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs))
+ (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2))))
+ (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key
#'car))
+ (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2))
:test #'equal))
+ (should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key
#'car :test #'equal)))
+
+(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy ()
+ (let ((animals (hierarchy-animals)))
+ (should (hierarchy-equal animals animals))
+ (should (hierarchy-equal (hierarchy-animals) animals))))
+
+(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies ()
+ (let ((animals (hierarchy-animals)))
+ (should (hierarchy-equal animals (hierarchy-copy animals)))))
+
+(ert-deftest hierarchy-map-item-on-leaf ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-map-item (lambda (item indent) (cons item indent))
+ 'cow
+ animals)))
+ (should (equal result '((cow . 0))))))
+
+(ert-deftest hierarchy-map-item-on-leaf-with-indent ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-map-item (lambda (item indent) (cons item indent))
+ 'cow
+ animals
+ 2)))
+ (should (equal result '((cow . 2))))))
+
+(ert-deftest hierarchy-map-item-on-parent ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-map-item (lambda (item indent) (cons item indent))
+ 'bird
+ animals)))
+ (should (equal result '((bird . 0) (dove . 1) (pigeon . 1))))))
+
+(ert-deftest hierarchy-map-item-on-grand-parent ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-map-item (lambda (item indent) (cons item indent))
+ 'animal
+ animals)))
+ (should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2)
+ (cow . 1) (dolphin . 1))))))
+
+(ert-deftest hierarchy-map-conses ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-map (lambda (item indent)
+ (cons item indent))
+ animals)))
+ (should (equal result '((animal . 0)
+ (bird . 1)
+ (dove . 2)
+ (pigeon . 2)
+ (cow . 1)
+ (dolphin . 1))))))
+
+(ert-deftest hierarchy-map-tree ()
+ (let ((animals (hierarchy-animals)))
+ (should (equal (hierarchy-map-tree (lambda (item indent children)
+ (list item indent children))
+ animals)
+ '(animal
+ 0
+ ((bird 1 ((dove 2 nil) (pigeon 2 nil)))
+ (cow 1 nil)
+ (dolphin 1 nil)))))))
+
+(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-map-hierarchy (lambda (item _) (identity item))
+ animals)))
+ (should (hierarchy-equal animals result))))
+
+(ert-deftest hierarchy-map-applies-function ()
+ (let* ((animals (hierarchy-animals))
+ (parentfn (lambda (item)
+ (cond
+ ((equal item "bird") "animal")
+ ((equal item "dove") "bird")
+ ((equal item "pigeon") "bird")
+ ((equal item "cow") "animal")
+ ((equal item "dolphin") "animal"))))
+ (expected (hierarchy-new)))
+ (hierarchy-add-tree expected "dove" parentfn)
+ (hierarchy-add-tree expected "pigeon" parentfn)
+ (hierarchy-add-tree expected "cow" parentfn)
+ (hierarchy-add-tree expected "dolphin" parentfn)
+ (should (hierarchy-equal
+ (hierarchy-map-hierarchy (lambda (item _) (symbol-name item))
animals)
+ expected))))
+
+(ert-deftest hierarchy-extract-tree ()
+ (let* ((animals (hierarchy-animals))
+ (birds (hierarchy-extract-tree animals 'bird)))
+ (hierarchy-sort birds)
+ (should (equal (hierarchy-roots birds) '(animal)))
+ (should (equal (hierarchy-children birds 'animal) '(bird)))
+ (should (equal (hierarchy-children birds 'bird) '(dove pigeon)))))
+
+(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy ()
+ (let* ((animals (hierarchy-animals)))
+ (should-not (hierarchy-extract-tree animals 'foobar))))
+
+(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty ()
+ (should (seq-empty-p (hierarchy-items (hierarchy-new)))))
+
+(ert-deftest hierarchy-items-returns-sequence-of-same-length ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-items animals)))
+ (should (= (seq-length result) (hierarchy-length animals)))))
+
+(ert-deftest hierarchy-items-return-all-elements-of-hierarchy ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-items animals)))
+ (should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove
pigeon)))))
+
+(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 ()
+ (let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (labelfn (hierarchy-labelfn-indent labelfn-base)))
+ (should (equal
+ (with-temp-buffer
+ (funcall labelfn "bar" 0)
+ (buffer-substring (point-min) (point-max)))
+ "foo"))))
+
+(ert-deftest hierarchy-labelfn-indent-three-times-if-3 ()
+ (let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (labelfn (hierarchy-labelfn-indent labelfn-base)))
+ (should (equal
+ (with-temp-buffer
+ (funcall labelfn "bar" 3)
+ (buffer-substring (point-min) (point-max)))
+ " foo"))))
+
+(ert-deftest hierarchy-labelfn-indent-default-indent-string ()
+ (let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (labelfn (hierarchy-labelfn-indent labelfn-base)))
+ (should (equal
+ (with-temp-buffer
+ (funcall labelfn "bar" 1)
+ (buffer-substring (point-min) (point-max)))
+ " foo"))))
+
+(ert-deftest hierarchy-labelfn-indent-custom-indent-string ()
+ (let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (labelfn (hierarchy-labelfn-indent labelfn-base "###"))
+ (content (with-temp-buffer
+ (funcall labelfn "bar" 1)
+ (buffer-substring (point-min) (point-max)))))
+ (should (equal content "###foo"))))
+
+(ert-deftest hierarchy-labelfn-button-propertize ()
+ (let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (actionfn #'identity)
+ (labelfn (hierarchy-labelfn-button labelfn-base actionfn))
+ (properties (with-temp-buffer
+ (funcall labelfn "bar" 1)
+ (text-properties-at 1))))
+ (should (equal (car properties) 'action))))
+
+(ert-deftest hierarchy-labelfn-button-execute-labelfn ()
+ (let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (actionfn #'identity)
+ (labelfn (hierarchy-labelfn-button labelfn-base actionfn))
+ (content (with-temp-buffer
+ (funcall labelfn "bar" 1)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (should (equal content "foo"))))
+
+(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition ()
+ (let ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (spy-count 0)
+ (condition (lambda (_item _indent) nil)))
+ (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn
_actionfn) (lambda (_item _indent) (cl-incf spy-count)))))
+ (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity)
nil nil)
+ (should (equal spy-count 0)))))
+
+(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition ()
+ (let ((labelfn-base (lambda (_item _indent) (insert "foo")))
+ (spy-count 0)
+ (condition (lambda (_item _indent) t)))
+ (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn
_actionfn) (lambda (_item _indent) (cl-incf spy-count)))))
+ (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity)
nil nil)
+ (should (equal spy-count 1)))))
+
+(ert-deftest hierarchy-labelfn-to-string ()
+ (let ((labelfn (lambda (item _indent) (insert item))))
+ (should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo"))))
+
+(ert-deftest hierarchy-print ()
+ (let* ((animals (hierarchy-animals))
+ (result (with-temp-buffer
+ (hierarchy-print animals)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (should (equal result "animal\n bird\n dove\n pigeon\n cow\n
dolphin\n"))))
+
+(ert-deftest hierarchy-to-string ()
+ (let* ((animals (hierarchy-animals))
+ (result (hierarchy-to-string animals)))
+ (should (equal result "animal\n bird\n dove\n pigeon\n cow\n
dolphin\n"))))
+
+(ert-deftest hierarchy-tabulated-display ()
+ (let* ((animals (hierarchy-animals))
+ (labelfn (lambda (item _indent) (insert (symbol-name item))))
+ (contents (with-temp-buffer
+ (hierarchy-tabulated-display animals labelfn
(current-buffer))
+ (buffer-substring-no-properties (point-min)
(point-max)))))
+ (should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n"))))
+
+(ert-deftest hierarchy-sort-non-root-nodes ()
+ (let* ((animals (hierarchy-animals)))
+ (should (equal (hierarchy-roots animals) '(animal)))
+ (should (equal (hierarchy-children animals 'animal) '(bird cow dolphin)))
+ (should (equal (hierarchy-children animals 'bird) '(dove pigeon)))))
+
+(ert-deftest hierarchy-sort-roots ()
+ (let* ((organisms (hierarchy-new))
+ (parentfn (lambda (item)
+ (cl-case item
+ (oak 'plant)
+ (bird 'animal)))))
+ (hierarchy-add-tree organisms 'oak parentfn)
+ (hierarchy-add-tree organisms 'bird parentfn)
+ (hierarchy-sort organisms)
+ (should (equal (hierarchy-roots organisms) '(animal plant)))))
+
+(provide 'hierarchy-tests)
+;;; hierarchy-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
new file mode 100644
index 0000000..27f48fa
--- /dev/null
+++ b/test/lisp/erc/erc-tests.el
@@ -0,0 +1,47 @@
+;;; erc-tests.el --- Tests for erc. -*- lexical-binding:t -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Lars Ingebrigtsen <larsi@gnus.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'erc)
+
+(ert-deftest erc--read-time-period ()
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "")))
+ (should (equal (erc--read-time-period "foo: ") nil)))
+
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " ")))
+ (should (equal (erc--read-time-period "foo: ") nil)))
+
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 432 ")))
+ (should (equal (erc--read-time-period "foo: ") 432)))
+
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "432")))
+ (should (equal (erc--read-time-period "foo: ") 432)))
+
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h")))
+ (should (equal (erc--read-time-period "foo: ") 3600)))
+
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h10s")))
+ (should (equal (erc--read-time-period "foo: ") 3610)))
+
+ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d")))
+ (should (equal (erc--read-time-period "foo: ") 86400))))
diff --git a/test/lisp/gnus/gnus-util-tests.el
b/test/lisp/gnus/gnus-util-tests.el
new file mode 100644
index 0000000..b01e2fc
--- /dev/null
+++ b/test/lisp/gnus/gnus-util-tests.el
@@ -0,0 +1,76 @@
+;;; gnus-util-tests.el --- Selectived tests only.
+;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
+
+;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org>
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'gnus-util)
+
+(ert-deftest gnus-subsetp ()
+ ;; False for non-lists.
+ (should-not (gnus-subsetp "1" "1"))
+ (should-not (gnus-subsetp "1" '("1")))
+ (should-not (gnus-subsetp '("1") "1"))
+
+ ;; Real tests.
+ (should (gnus-subsetp '() '()))
+ (should (gnus-subsetp '() '("1")))
+ (should (gnus-subsetp '("1") '("1")))
+ (should (gnus-subsetp '(42) '("1" 42)))
+ (should (gnus-subsetp '(42) '(42 "1")))
+ (should (gnus-subsetp '(42) '("1" 42 2)))
+ (should-not (gnus-subsetp '("1") '()))
+ (should-not (gnus-subsetp '("1") '(2)))
+ (should-not (gnus-subsetp '("1" 2) '(2)))
+ (should-not (gnus-subsetp '(2 "1") '(2)))
+ (should-not (gnus-subsetp '("1" 2) '(2 3)))
+
+ ;; Duplicates don't matter for sets.
+ (should (gnus-subsetp '("1" "1") '("1")))
+ (should (gnus-subsetp '("1" 2 "1") '(2 "1")))
+ (should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2)))
+ (should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2))))
+
+(ert-deftest gnus-setdiff ()
+ ;; False for non-lists.
+ (should-not (gnus-setdiff "1" "1"))
+ (should-not (gnus-setdiff "1" '()))
+ (should-not (gnus-setdiff '() "1"))
+
+ ;; Real tests.
+ (should-not (gnus-setdiff '() '()))
+ (should-not (gnus-setdiff '() '("1")))
+ (should-not (gnus-setdiff '("1") '("1")))
+ (should (equal '("1") (gnus-setdiff '("1") '())))
+ (should (equal '("1") (gnus-setdiff '("1") '(2))))
+ (should (equal '("1") (gnus-setdiff '("1" 2) '(2))))
+ (should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2))))
+ (should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2))))
+ (should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2))))
+ (should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3))))
+
+ ;; Duplicates aren't touched for sets if they are not removed.
+ (should-not (gnus-setdiff '("1" "1") '("1")))
+ (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2))))
+ (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2)))))
+
+;;; gnustest-gnus-util.el ends here
diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el
new file mode 100644
index 0000000..8f78a66
--- /dev/null
+++ b/test/lisp/gnus/mml-sec-tests.el
@@ -0,0 +1,895 @@
+;;; gnustest-mml-sec.el --- Tests mml-sec.el, see README-mml-secure.txt.
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org>
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+
+(require 'message)
+(require 'epa)
+(require 'epg)
+(require 'mml-sec)
+(require 'gnus-sum)
+
+(defvar with-smime nil
+ "If nil, exclude S/MIME from tests as passphrases need to entered manually.
+Mostly, the empty passphrase is used. However, the keys for
+ \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well
+ as S/MIME).")
+
+(defun test-conf ()
+ (ignore-errors (epg-configuration)))
+
+(defun enc-standards ()
+ (if with-smime '(enc-pgp enc-pgp-mime enc-smime)
+ '(enc-pgp enc-pgp-mime)))
+(defun enc-sign-standards ()
+ (if with-smime
+ '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime)
+ '(enc-sign-pgp enc-sign-pgp-mime)))
+(defun sign-standards ()
+ (if with-smime
+ '(sign-pgp sign-pgp-mime sign-smime)
+ '(sign-pgp sign-pgp-mime)))
+
+(defun mml-secure-test-fixture (body &optional interactive)
+ "Setup GnuPG home containing test keys and prepare environment for BODY.
+If optional INTERACTIVE is non-nil, allow questions to the user in case of
+key problems.
+This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests,
+which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess.
+Actually, I'm not sure why people would want to cache passwords in Emacs
+instead of gpg-agent."
+ (unwind-protect
+ (let ((agent-info (getenv "GPG_AGENT_INFO"))
+ (gpghome (getenv "GNUPGHOME")))
+ (condition-case error
+ (let ((epg-gpg-home-directory
+ (expand-file-name "test/data/mml-sec" source-directory))
+ (mml-secure-allow-signing-with-unknown-recipient t)
+ (mml-smime-use 'epg)
+ ;; Create debug output in empty epg-debug-buffer.
+ (epg-debug t)
+ (epg-debug-buffer (get-buffer-create " *epg-test*"))
+ (mml-secure-fail-when-key-problem (not interactive)))
+ (with-current-buffer epg-debug-buffer
+ (erase-buffer))
+ ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs.
+ ;; Just for testing. Jens does not recommend this for daily use.
+ (setenv "GPG_AGENT_INFO")
+ ;; Set GNUPGHOME as gpg-agent started by gpgsm does
+ ;; not look in the proper places otherwise, see:
+ ;; https://bugs.gnupg.org/gnupg/issue2126
+ (setenv "GNUPGHOME" epg-gpg-home-directory)
+ (funcall body))
+ (error
+ (setenv "GPG_AGENT_INFO" agent-info)
+ (setenv "GNUPGHOME" gpghome)
+ (signal (car error) (cdr error))))
+ (setenv "GPG_AGENT_INFO" agent-info)
+ (setenv "GNUPGHOME" gpghome))))
+
+(defun mml-secure-test-message-setup (method to from &optional text bcc)
+ "Setup a buffer with MML METHOD, TO, and FROM headers.
+Optionally, a message TEXT and BCC header can be passed."
+ (with-temp-buffer
+ (when bcc (insert (format "Bcc: %s\n" bcc)))
+ (insert (format "To: %s
+From: %s
+Subject: Test
+%s\n" to from mail-header-separator))
+ (if text
+ (insert (format "%s" text))
+ (spook))
+ (cond ((eq method 'enc-pgp-mime)
+ (mml-secure-message-encrypt-pgpmime 'nosig))
+ ((eq method 'enc-sign-pgp-mime)
+ (mml-secure-message-encrypt-pgpmime))
+ ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig))
+ ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp))
+ ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig))
+ ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime))
+ ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime))
+ ((eq method 'sign-pgp) (mml-secure-message-sign-pgp))
+ ((eq method 'sign-smime) (mml-secure-message-sign-smime))
+ (t (error "Unknown method")))
+ (buffer-string)))
+
+(defun mml-secure-test-mail-fixture (method to from body2
+ &optional interactive)
+ "Setup buffer encrypted using METHOD for TO from FROM, call BODY2.
+Pass optional INTERACTIVE to mml-secure-test-fixture."
+ (mml-secure-test-fixture
+ (lambda ()
+ (let ((context (if (memq method '(enc-smime enc-sign-smime sign-smime))
+ (epg-make-context 'CMS)
+ (epg-make-context 'OpenPGP)))
+ ;; Verify and decrypt by default.
+ (mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (plaintext "The Magic Words are Squeamish Ossifrage"))
+ (with-temp-buffer
+ (insert (mml-secure-test-message-setup method to from plaintext))
+ (message-options-set-recipient)
+ (message-encode-message-body)
+ ;; Replace separator line with newline.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ ;; The following treatment of handles, plainbuf, and multipart
+ ;; resulted from trial-and-error.
+ ;; Someone with more knowledge on how to decrypt messages and verify
+ ;; signatures might know more appropriate functions to invoke
+ ;; instead.
+ (let* ((handles (or (mm-dissect-buffer)
+ (mm-uu-dissect)))
+ (isplain (bufferp (car handles)))
+ (ismultipart (equal (car handles) "multipart/mixed"))
+ (plainbuf (if isplain
+ (car handles)
+ (if ismultipart
+ (car (cadadr handles))
+ (caadr handles))))
+ (decrypted
+ (with-current-buffer plainbuf (buffer-string)))
+ (gnus-info
+ (if isplain
+ nil
+ (if ismultipart
+ (or (mm-handle-multipart-ctl-parameter
+ (cadr handles) 'gnus-details)
+ (mm-handle-multipart-ctl-parameter
+ (cadr handles) 'gnus-info))
+ (mm-handle-multipart-ctl-parameter
+ handles 'gnus-info)))))
+ (funcall body2 gnus-info plaintext decrypted)))))
+ interactive))
+
+;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion
+;; occurs. Emacs bug?
+(defun mml-secure-test-key-fixture (body3)
+ "Customize unique keys for sub@example.org and call BODY3.
+For OpenPGP, we have:
+- 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2
+ uid Different subkeys <sub@example.org>
+- 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471
+ uid Second Key Pair <sub@example.org>
+
+For S/MIME:
+ ID: 0x479DC6E2
+ Subject: /CN=Second Key Pair
+ aka: sub@example.org
+ fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2
+
+ ID: 0x5F88E9FC
+ Subject: /CN=Different subkeys
+ aka: sub@example.org
+ fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC
+
+In both cases, the first key is customized for signing and encryption."
+ (mml-secure-test-fixture
+ (lambda ()
+ (let* ((mml-secure-key-preferences
+ '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
+ (pcontext (epg-make-context 'OpenPGP))
+ (pkey (epg-list-keys pcontext "C3999CF1268DBEA2"))
+ (scontext (epg-make-context 'CMS))
+ (skey (epg-list-keys scontext "0x479DC6E2")))
+ (mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey)
+ (mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey)
+ (mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey)
+ (mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey)
+ (funcall body3)))))
+
+(ert-deftest mml-secure-key-checks ()
+ "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let* ((context (epg-make-context 'OpenPGP))
+ (keys1 (epg-list-keys context "expired@example.org"))
+ (keys2 (epg-list-keys context "no-exp@example.org"))
+ (keys3 (epg-list-keys context "sub@example.org"))
+ (keys4 (epg-list-keys context "revoked-uid@example.org"))
+ (keys5 (epg-list-keys context "disabled@example.org"))
+ (keys6 (epg-list-keys context "sign@example.org"))
+ (keys7 (epg-list-keys context "jens.lechtenboerger@fsfe"))
+ )
+ (should (and (= 1 (length keys1)) (= 1 (length keys2))
+ (= 2 (length keys3))
+ (= 1 (length keys4)) (= 1 (length keys5))
+ ))
+ ;; key1 is expired
+ (should-not (mml-secure-check-user-id (car keys1)
"expired@example.org"))
+ (should-not (mml-secure-check-sub-key context (car keys1) 'encrypt))
+ (should-not (mml-secure-check-sub-key context (car keys1) 'sign))
+
+ ;; key2 does not expire, but does not have the UID expired@example.org
+ (should-not (mml-secure-check-user-id (car keys2)
"expired@example.org"))
+ (should (mml-secure-check-user-id (car keys2) "no-exp@example.org"))
+ (should (mml-secure-check-sub-key context (car keys2) 'encrypt))
+ (should (mml-secure-check-sub-key context (car keys2) 'sign))
+
+ ;; Two keys exist for sub@example.org.
+ (should (mml-secure-check-user-id (car keys3) "sub@example.org"))
+ (should (mml-secure-check-sub-key context (car keys3) 'encrypt))
+ (should (mml-secure-check-sub-key context (car keys3) 'sign))
+ (should (mml-secure-check-user-id (cadr keys3) "sub@example.org"))
+ (should (mml-secure-check-sub-key context (cadr keys3) 'encrypt))
+ (should (mml-secure-check-sub-key context (cadr keys3) 'sign))
+
+ ;; The UID revoked-uid@example.org is revoked. The key itself is
+ ;; usable, though (with the UID sub@example.org).
+ (should-not
+ (mml-secure-check-user-id (car keys4) "revoked-uid@example.org"))
+ (should (mml-secure-check-sub-key context (car keys4) 'encrypt))
+ (should (mml-secure-check-sub-key context (car keys4) 'sign))
+ (should (mml-secure-check-user-id (car keys4) "sub@example.org"))
+
+ ;; The next key is disabled and, thus, unusable.
+ (should (mml-secure-check-user-id (car keys5) "disabled@example.org"))
+ (should-not (mml-secure-check-sub-key context (car keys5) 'encrypt))
+ (should-not (mml-secure-check-sub-key context (car keys5) 'sign))
+
+ ;; The next key has multiple subkeys.
+ ;; 42466F0F is valid sign subkey, 501FFD98 is expired
+ (should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F"))
+ (should-not
+ (mml-secure-check-sub-key context (car keys6) 'sign "501FFD98"))
+ ;; DC7F66E7 is encrypt subkey
+ (should
+ (mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7"))
+ (should-not
+ (mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7"))
+ (should-not
+ (mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F"))
+
+ ;; The final key is just a public key.
+ (should (mml-secure-check-sub-key context (car keys7) 'encrypt))
+ (should-not (mml-secure-check-sub-key context (car keys7) 'sign))
+ ))))
+
+(ert-deftest mml-secure-find-usable-keys-1 ()
+ "Make sure that expired and disabled keys and revoked UIDs are not used."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let ((context (epg-make-context 'OpenPGP)))
+ (should-not
+ (mml-secure-find-usable-keys context "expired@example.org" 'encrypt))
+ (should-not
+ (mml-secure-find-usable-keys context "expired@example.org" 'sign))
+
+ (should-not
+ (mml-secure-find-usable-keys context "disabled@example.org" 'encrypt))
+ (should-not
+ (mml-secure-find-usable-keys context "disabled@example.org" 'sign))
+
+ (should-not
+ (mml-secure-find-usable-keys
+ context "<revoked-uid@example.org>" 'encrypt))
+ (should-not
+ (mml-secure-find-usable-keys
+ context "<revoked-uid@example.org>" 'sign))
+ ;; Same test without ankles. Will fail for Ma Gnus v0.14 and earlier.
+ (should-not
+ (mml-secure-find-usable-keys
+ context "revoked-uid@example.org" 'encrypt))
+
+ ;; Expired key should not be usable.
+ ;; Will fail for Ma Gnus v0.14 and earlier.
+ ;; sign@example.org has the expired subkey 0x501FFD98.
+ (should-not
+ (mml-secure-find-usable-keys context "0x501FFD98" 'sign))
+
+ (should
+ (mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt))
+ (should
+ (mml-secure-find-usable-keys context "no-exp@example.org" 'sign))
+ ))))
+
+(ert-deftest mml-secure-find-usable-keys-2 ()
+ "Test different ways to search for keys."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let ((context (epg-make-context 'OpenPGP)))
+ ;; Plain substring search is not supported.
+ (should
+ (= 0 (length
+ (mml-secure-find-usable-keys context "No Expiry" 'encrypt))))
+ (should
+ (= 0 (length
+ (mml-secure-find-usable-keys context "No Expiry" 'sign))))
+
+ ;; Search for e-mail addresses works with and without ankle brackets.
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "<no-exp@example.org>" 'encrypt))))
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "<no-exp@example.org>" 'sign))))
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "no-exp@example.org" 'encrypt))))
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "no-exp@example.org" 'sign))))
+
+ ;; Use full UID string.
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "No Expiry <no-exp@example.org>" 'encrypt))))
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "No Expiry <no-exp@example.org>" 'sign))))
+
+ ;; If just the public key is present, only encryption is possible.
+ ;; Search works with key IDs, with and without prefix "0x".
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "A142FD84" 'encrypt))))
+ (should
+ (= 1 (length (mml-secure-find-usable-keys
+ context "0xA142FD84" 'encrypt))))
+ (should
+ (= 0 (length (mml-secure-find-usable-keys
+ context "A142FD84" 'sign))))
+ (should
+ (= 0 (length (mml-secure-find-usable-keys
+ context "0xA142FD84" 'sign))))
+ ))))
+
+(ert-deftest mml-secure-select-preferred-keys-1 ()
+ "If only one key exists for an e-mail address, it is the preferred one."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let ((context (epg-make-context 'OpenPGP)))
+ (should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB"
+ (mml-secure-fingerprint
+ (car (mml-secure-select-preferred-keys
+ context '("no-exp@example.org") 'encrypt)))))))))
+
+(ert-deftest mml-secure-select-preferred-keys-2 ()
+ "If multiple keys exists for an e-mail address, customization is necessary."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let* ((context (epg-make-context 'OpenPGP))
+ (mml-secure-key-preferences
+ '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
+ (pref (car (mml-secure-find-usable-keys
+ context "sub@example.org" 'encrypt))))
+ (should-error (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'encrypt))
+ (mml-secure-cust-record-keys
+ context 'encrypt "sub@example.org" (list pref))
+ (should (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'encrypt))
+ (should-error (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'sign))
+ (should (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'encrypt))
+ (should
+ (equal (list (mml-secure-fingerprint pref))
+ (mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org")))
+ (should (mml-secure-cust-remove-keys context 'encrypt
"sub@example.org"))
+ (should-error (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'encrypt))))))
+
+(ert-deftest mml-secure-select-preferred-keys-3 ()
+ "Expired customized keys are removed if multiple keys are available."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let ((context (epg-make-context 'OpenPGP))
+ (mml-secure-key-preferences
+ '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))))
+ ;; sub@example.org has two keys (268DBEA2, AE31D471).
+ ;; Normal preference works.
+ (mml-secure-cust-record-keys
+ context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2"))
+ (should (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'encrypt))
+ (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")
+
+ ;; Fake preference for expired (unrelated) key CE15FAE7,
+ ;; results in error (and automatic removal of outdated preference).
+ (mml-secure-cust-record-keys
+ context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7"))
+ (should-error (mml-secure-select-preferred-keys
+ context '("sub@example.org") 'encrypt))
+ (should-not
+ (mml-secure-cust-remove-keys context 'encrypt "sub@example.org"))))))
+
+(ert-deftest mml-secure-select-preferred-keys-4 ()
+ "Multiple keys can be recorded per recipient or signature."
+ (skip-unless (test-conf))
+ (mml-secure-test-fixture
+ (lambda ()
+ (let ((pcontext (epg-make-context 'OpenPGP))
+ (scontext (epg-make-context 'CMS))
+ (pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"
+ "14632ECAB9E227369C8DD97BF7E79AB7AE31D471"))
+ (skeys '("0x5F88E9FC" "0x479DC6E2"))
+ (mml-secure-key-preferences
+ '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))))
+
+ ;; OpenPGP preferences via pcontext
+ (dolist (key pkeys nil)
+ (mml-secure-cust-record-keys
+ pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key))
+ (mml-secure-cust-record-keys
+ pcontext 'sign "sub@example.org" (epg-list-keys pcontext key
'secret)))
+ (let ((p-e-fprs (mml-secure-cust-fpr-lookup
+ pcontext 'encrypt "sub@example.org"))
+ (p-s-fprs (mml-secure-cust-fpr-lookup
+ pcontext 'sign "sub@example.org")))
+ (should (= 2 (length p-e-fprs)))
+ (should (= 2 (length p-s-fprs)))
+ (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs))
+ (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs))
+ (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs))
+ (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs)))
+ ;; Duplicate record does not change anything.
+ (mml-secure-cust-record-keys
+ pcontext 'encrypt "sub@example.org"
+ (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"))
+ (mml-secure-cust-record-keys
+ pcontext 'sign "sub@example.org"
+ (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"))
+ (let ((p-e-fprs (mml-secure-cust-fpr-lookup
+ pcontext 'encrypt "sub@example.org"))
+ (p-s-fprs (mml-secure-cust-fpr-lookup
+ pcontext 'sign "sub@example.org")))
+ (should (= 2 (length p-e-fprs)))
+ (should (= 2 (length p-s-fprs))))
+
+ ;; S/MIME preferences via scontext
+ (dolist (key skeys nil)
+ (mml-secure-cust-record-keys
+ scontext 'encrypt "sub@example.org"
+ (epg-list-keys scontext key))
+ (mml-secure-cust-record-keys
+ scontext 'sign "sub@example.org"
+ (epg-list-keys scontext key 'secret)))
+ (let ((s-e-fprs (mml-secure-cust-fpr-lookup
+ scontext 'encrypt "sub@example.org"))
+ (s-s-fprs (mml-secure-cust-fpr-lookup
+ scontext 'sign "sub@example.org")))
+ (should (= 2 (length s-e-fprs)))
+ (should (= 2 (length s-s-fprs))))
+ ))))
+
+(defun mml-secure-test-en-decrypt
+ (method to from
+ &optional checksig checkplain enc-keys expectfail interactive)
+ "Encrypt message using METHOD, addressed to TO, from FROM.
+If optional CHECKSIG is non-nil, it must be a number, and a signature check is
+performed; the number indicates how many signatures are expected.
+If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained
+via decryption.
+If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for
+OpenPGP and S/SMIME) expected in `epg-debug-buffer'.
+If optional EXPECTFAIL is non-nil, a decryption failure is expected.
+Pass optional INTERACTIVE to mml-secure-test-mail-fixture."
+ (mml-secure-test-mail-fixture method to from
+ (lambda (gnus-info plaintext decrypted)
+ (if expectfail
+ (should-not (equal plaintext decrypted))
+ (when checkplain
+ (should (equal plaintext decrypted)))
+ (let ((protocol (if (memq method
+ '(enc-smime enc-sign-smime sign-smime))
+ 'CMS
+ 'OpenPGP)))
+ (when checksig
+ (let* ((context (epg-make-context protocol))
+ (signer-names (mml-secure-signer-names protocol from))
+ (signer-keys (mml-secure-signers context signer-names))
+ (signer-fprs (mapcar 'mml-secure-fingerprint signer-keys)))
+ (should (eq checksig (length signer-fprs)))
+ (if (eq checksig 0)
+ ;; First key in keyring
+ (should (string-match-p
+ (concat "Good signature from "
+ (if (eq protocol 'CMS)
+ "0E58229B80EE33959FF718FEEF25402B479DC6E2"
+ "02372A42CA6D40FB"))
+ gnus-info)))
+ (dolist (fpr signer-fprs nil)
+ ;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry
<no-exp@example.org> (trust undefined) created ..."
+ ;; S/MIME: "Good signature from
D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..."
+ (should (string-match-p
+ (concat "Good signature from "
+ (if (eq protocol 'CMS)
+ fpr
+ (substring fpr -16 nil)))
+ gnus-info)))))
+ (when enc-keys
+ (with-current-buffer epg-debug-buffer
+ (goto-char (point-min))
+ ;; The following regexp does not necessarily match at the
+ ;; start of the line as a path may or may not be present.
+ ;; Also note that gpg.* matches gpg2 and gpgsm as well.
+ (let* ((line (concat "gpg.*--encrypt.*$"))
+ (end (re-search-forward line))
+ (match (match-string 0)))
+ (should (and end match))
+ (dolist (pair enc-keys nil)
+ (let ((fpr (if (eq protocol 'OpenPGP)
+ (car pair)
+ (cdr pair))))
+ (should (string-match-p (concat "-r " fpr) match))))
+ (goto-char (point-max))
+ ))))))
+ interactive))
+
+(defun mml-secure-test-en-decrypt-with-passphrase
+ (method to from checksig jl-passphrase do-cache
+ &optional enc-keys expectfail)
+ "Call mml-secure-test-en-decrypt with changed passphrase caching.
+Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt.
+JL-PASSPHRASE is fixed as return value for `read-passwd',
+boolean DO-CACHE determines whether to cache the passphrase.
+If optional ENC-KEYS is non-nil, it is a list of encryption keys expected
+in `epg-debug-buffer'.
+If optional EXPECTFAIL is non-nil, a decryption failure is expected."
+ (let ((mml-secure-cache-passphrase do-cache)
+ (mml1991-cache-passphrase do-cache)
+ (mml2015-cache-passphrase do-cache)
+ (mml-smime-cache-passphrase do-cache)
+ )
+ (cl-letf (((symbol-function 'read-passwd)
+ (lambda (prompt &optional confirm default) jl-passphrase)))
+ (mml-secure-test-en-decrypt method to from checksig t enc-keys
expectfail)
+ )))
+
+(ert-deftest mml-secure-en-decrypt-1 ()
+ "Encrypt message; then decrypt and test for expected result.
+In this test, the single matching key is chosen automatically."
+ (skip-unless (test-conf))
+ (dolist (method (enc-standards) nil)
+ ;; no-exp@example.org with single encryption key
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" nil t
+ (list (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))
+
+(ert-deftest mml-secure-en-decrypt-2 ()
+ "Encrypt message; then decrypt and test for expected result.
+In this test, the encryption key needs to fixed among multiple ones."
+ (skip-unless (test-conf))
+ ;; sub@example.org with multiple candidate keys,
+ ;; fixture customizes preferred ones.
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (dolist (method (enc-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "no-exp@example.org" nil t
+ (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")))))))
+
+(ert-deftest mml-secure-en-decrypt-3 ()
+ "Encrypt message; then decrypt and test for expected result.
+In this test, encrypt-to-self variables are set to t."
+ (skip-unless (test-conf))
+ ;; sub@example.org with multiple candidate keys,
+ ;; fixture customizes preferred ones.
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (let ((mml-secure-openpgp-encrypt-to-self t)
+ (mml-secure-smime-encrypt-to-self t))
+ (dolist (method (enc-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "no-exp@example.org" nil t
+ (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
+ (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))))))
+
+(ert-deftest mml-secure-en-decrypt-4 ()
+ "Encrypt message; then decrypt and test for expected result.
+In this test, encrypt-to-self variables are set to lists."
+ (skip-unless (test-conf))
+ ;; Send from sub@example.org, which has two keys; encrypt to both.
+ (let ((mml-secure-openpgp-encrypt-to-self
+ '("C3999CF1268DBEA2" "F7E79AB7AE31D471"))
+ (mml-secure-smime-encrypt-to-self
+ '("EF25402B479DC6E2" "4035D59B5F88E9FC")))
+ (dolist (method (enc-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" nil t
+ (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
+ (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC"))))))
+
+(ert-deftest mml-secure-en-decrypt-sign-1-1-single ()
+ "Sign and encrypt message; then decrypt and test for expected result.
+In this test, just multiple encryption and signing keys may be available."
+ :tags '(:unstable)
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (let ((mml-secure-openpgp-sign-with-sender t)
+ (mml-secure-smime-sign-with-sender t))
+ (dolist (method (enc-sign-standards) nil)
+ ;; no-exp with just one key
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "no-exp@example.org" 1 t)
+ ;; customized choice for encryption key
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "no-exp@example.org" 1 t)
+ ;; customized choice for signing key
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" 1 t)
+ ;; customized choice for both keys
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "sub@example.org" 1 t)
+ )))))
+
+(ert-deftest mml-secure-en-decrypt-sign-1-2-double ()
+ "Sign and encrypt message; then decrypt and test for expected result.
+In this test, just multiple encryption and signing keys may be available."
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (let ((mml-secure-openpgp-sign-with-sender t)
+ (mml-secure-smime-sign-with-sender t))
+ ;; Now use both keys to sign. The customized one via sign-with-sender,
+ ;; the other one via the following setting.
+ (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471"))
+ (mml-secure-smime-signers '("0x5F88E9FC")))
+ (dolist (method (enc-sign-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" 2 t)))))))
+
+(ert-deftest mml-secure-en-decrypt-sign-1-3-double ()
+ "Sign and encrypt message; then decrypt and test for expected result.
+In this test, just multiple encryption and signing keys may be available."
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ ;; Now use both keys for sub@example.org to sign an e-mail from
+ ;; a different address (without associated keys).
+ (let ((mml-secure-openpgp-sign-with-sender nil)
+ (mml-secure-smime-sign-with-sender nil)
+ (mml-secure-openpgp-signers
+ '("F7E79AB7AE31D471" "C3999CF1268DBEA2"))
+ (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2")))
+ (dolist (method (enc-sign-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "no-keys@example.org" 2 t))))))
+
+(ert-deftest mml-secure-en-decrypt-sign-2 ()
+ "Sign and encrypt message; then decrypt and test for expected result.
+In this test, lists of encryption and signing keys are customized."
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (let ((mml-secure-key-preferences
+ '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
+ (pcontext (epg-make-context 'OpenPGP))
+ (scontext (epg-make-context 'CMS))
+ (mml-secure-openpgp-sign-with-sender t)
+ (mml-secure-smime-sign-with-sender t))
+ (dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil)
+ (mml-secure-cust-record-keys
+ pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key))
+ (mml-secure-cust-record-keys
+ pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t)))
+ (dolist (key '("0x5F88E9FC" "0x479DC6E2") nil)
+ (mml-secure-cust-record-keys
+ scontext 'encrypt "sub@example.org" (epg-list-keys scontext key))
+ (mml-secure-cust-record-keys
+ scontext 'sign "sub@example.org" (epg-list-keys scontext key t)))
+ (dolist (method (enc-sign-standards) nil)
+ ;; customized choice for encryption key
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "no-exp@example.org" 1 t)
+ ;; customized choice for signing key
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" 2 t)
+ ;; customized choice for both keys
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "sub@example.org" 2 t)
+ )))))
+
+(ert-deftest mml-secure-en-decrypt-sign-3 ()
+ "Sign and encrypt message; then decrypt and test for expected result.
+Use sign-with-sender and encrypt-to-self."
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (let ((mml-secure-openpgp-sign-with-sender t)
+ (mml-secure-openpgp-encrypt-to-self t)
+ (mml-secure-smime-sign-with-sender t)
+ (mml-secure-smime-encrypt-to-self t))
+ (dolist (method (enc-sign-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "sub@example.org" "no-exp@example.org" 1 t
+ (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
+ (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))
+ ))))
+
+(ert-deftest mml-secure-sign-verify-1 ()
+ "Sign message with sender; then verify and test for expected result."
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (dolist (method (sign-standards) nil)
+ (let ((mml-secure-openpgp-sign-with-sender t)
+ (mml-secure-smime-sign-with-sender t))
+ ;; A single signing key for sender sub@example.org is customized
+ ;; in the fixture.
+ (mml-secure-test-en-decrypt
+ method "uid1@example.org" "sub@example.org" 1 nil)
+
+ ;; From sub@example.org, sign with two keys;
+ ;; sign-with-sender and one from signers-variable:
+ (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
+ (mml-secure-smime-signers
+ '("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" 2 nil))
+ )))))
+
+(ert-deftest mml-secure-sign-verify-2 ()
+ "Sign message without sender; then verify and test for expected result."
+ (skip-unless (test-conf))
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (dolist (method (sign-standards) nil)
+ (let ((mml-secure-openpgp-sign-with-sender nil)
+ (mml-secure-smime-sign-with-sender nil))
+ ;; A single signing key for sender sub@example.org is customized
+ ;; in the fixture, but not used here.
+ ;; By default, gpg uses the first secret key in the keyring, which
+ ;; is 02372A42CA6D40FB (OpenPGP) or
+ ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here.
+ (mml-secure-test-en-decrypt
+ method "uid1@example.org" "sub@example.org" 0 nil)
+
+ ;; From sub@example.org, sign with specified key:
+ (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
+ (mml-secure-smime-signers
+ '("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" 1 nil))
+
+ ;; From sub@example.org, sign with different specified key:
+ (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2"))
+ (mml-secure-smime-signers
+ '("0E58229B80EE33959FF718FEEF25402B479DC6E2")))
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sub@example.org" 1 nil))
+ )))))
+
+(ert-deftest mml-secure-sign-verify-3 ()
+ "Try to sign message with expired OpenPGP subkey, which raises an error.
+With Ma Gnus v0.14 and earlier a signature would be created with a wrong key."
+ (skip-unless (test-conf))
+ (should-error
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (let ((with-smime nil)
+ (mml-secure-openpgp-sign-with-sender nil)
+ (mml-secure-openpgp-signers '("501FFD98")))
+ (dolist (method (sign-standards) nil)
+ (mml-secure-test-en-decrypt
+ method "no-exp@example.org" "sign@example.org" 1 nil)
+ ))))))
+
+;; TODO Passphrase passing and caching in Emacs does not seem to work
+;; with gpgsm at all.
+;; Independently of caching settings, a pinentry dialogue is displayed.
+;; Thus, the following tests require the user to enter the correct gpgsm
+;; passphrases at the correct points in time. (Either empty string or
+;; "Passphrase".)
+(ert-deftest mml-secure-en-decrypt-passphrase-cache ()
+ "Encrypt message; then decrypt and test for expected result.
+In this test, a key is used that requires the passphrase \"Passphrase\".
+In the first decryption this passphrase is hardcoded, in the second one it
+ is taken from a cache."
+ (skip-unless (test-conf))
+ (ert-skip "Requires passphrase")
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (dolist (method (enc-standards) nil)
+ (mml-secure-test-en-decrypt-with-passphrase
+ method "uid1@example.org" "sub@example.org" nil
+ ;; Beware! For passphrases copy-sequence is necessary, as they may
+ ;; be erased, which actually changes the function's code and causes
+ ;; multiple invokations to fail. I was surprised...
+ (copy-sequence "Passphrase") t)
+ (mml-secure-test-en-decrypt-with-passphrase
+ method "uid1@example.org" "sub@example.org" nil
+ (copy-sequence "Incorrect") t)))))
+
+(defun mml-secure-en-decrypt-passphrase-no-cache (method)
+ "Encrypt message with METHOD; then decrypt and test for expected result.
+In this test, a key is used that requires the passphrase \"Passphrase\".
+In the first decryption this passphrase is hardcoded, but caching disabled.
+So the second decryption fails."
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (mml-secure-test-en-decrypt-with-passphrase
+ method "uid1@example.org" "sub@example.org" nil
+ (copy-sequence "Passphrase") nil)
+ (mml-secure-test-en-decrypt-with-passphrase
+ method "uid1@example.org" "sub@example.org" nil
+ (copy-sequence "Incorrect") nil nil t))))
+
+(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo ()
+ "Passphrase caching with OpenPGP only for GnuPG 1.x."
+ (skip-unless (test-conf))
+ (skip-unless (string< (cdr (assq 'version (epg-configuration))) "2"))
+ (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp)
+ (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime))
+
+(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo ()
+ "Passphrase caching does not work with S/MIME (and gpgsm)."
+ :expected-result :failed
+ (skip-unless (test-conf))
+ (if with-smime
+ (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime)
+ (should nil)))
+
+
+;; Test truncation of question in y-or-n-p.
+(defun mml-secure-select-preferred-keys-todo ()
+ "Manual customization with truncated question."
+ (mml-secure-test-key-fixture
+ (lambda ()
+ (mml-secure-test-en-decrypt
+ 'enc-pgp-mime
+ "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de"
+ "no-exp@example.org" nil t nil nil t))))
+
+(defun mml-secure-select-preferred-keys-ok ()
+ "Manual customization with entire question."
+ (mml-secure-test-fixture
+ (lambda ()
+ (mml-secure-select-preferred-keys
+ (epg-make-context 'OpenPGP)
+ '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de")
+ 'encrypt))
+ t))
+
+
+;; ERT entry points
+(defun mml-secure-run-tests ()
+ "Run all tests with defaults."
+ (ert-run-tests-batch))
+
+(defun mml-secure-run-tests-with-gpg2 ()
+ "Run all tests with gpg2 instead of gpg."
+ (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2
+ (gpg-version (cdr (assq 'version (epg-configuration))))
+ ;; Empty passphrases do not seem to work with gpgsm in 2.1.x:
+ ;;
https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html
+ (with-smime (string< gpg-version "2.1")))
+ (ert-run-tests-batch)))
+
+(defun mml-secure-run-tests-without-smime ()
+ "Skip S/MIME tests (as they require manual passphrase entry)."
+ (let ((with-smime nil))
+ (ert-run-tests-batch)))
+
+;;; gnustest-mml-sec.el ends here
diff --git a/test/lisp/net/browse-url-tests.el
b/test/lisp/net/browse-url-tests.el
new file mode 100644
index 0000000..b2b27d2
--- /dev/null
+++ b/test/lisp/net/browse-url-tests.el
@@ -0,0 +1,119 @@
+;;; browse-url-tests.el --- Tests for browse-url.el -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Simen Heggestøyl <simenheg@gmail.com>
+;; Keywords:
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'browse-url)
+(require 'ert)
+
+(ert-deftest browse-url-tests-browser-kind ()
+ (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org")
+ 'internal))
+ (should
+ (eq (browse-url--browser-kind #'browse-url-firefox "gnu.org")
+ 'external)))
+
+(ert-deftest browse-url-tests-non-html-file-url-p ()
+ (should (browse-url--non-html-file-url-p "file://foo.txt"))
+ (should-not (browse-url--non-html-file-url-p "file://foo.html")))
+
+(ert-deftest browse-url-tests-select-handler-mailto ()
+ (should (eq (browse-url-select-handler "mailto:foo@bar.org";)
+ 'browse-url--mailto))
+ (should (eq (browse-url-select-handler "mailto:foo@bar.org";
+ 'internal)
+ 'browse-url--mailto))
+ (should-not (browse-url-select-handler "mailto:foo@bar.org";
+ 'external)))
+
+(ert-deftest browse-url-tests-select-handler-man ()
+ (should (eq (browse-url-select-handler "man:ls") 'browse-url--man))
+ (should (eq (browse-url-select-handler "man:ls" 'internal)
+ 'browse-url--man))
+ (should-not (browse-url-select-handler "man:ls" 'external)))
+
+(ert-deftest browse-url-tests-select-handler-file ()
+ (should (eq (browse-url-select-handler "file://foo.txt")
+ 'browse-url-emacs))
+ (should (eq (browse-url-select-handler "file://foo.txt" 'internal)
+ 'browse-url-emacs))
+ (should-not (browse-url-select-handler "file://foo.txt" 'external)))
+
+(ert-deftest browse-url-tests-url-encode-chars ()
+ (should (equal (browse-url-url-encode-chars "foobar" "[ob]")
+ "f%6F%6F%62ar")))
+
+(ert-deftest browse-url-tests-encode-url ()
+ (should (equal (browse-url-encode-url "") ""))
+ (should (equal (browse-url-encode-url "a b c") "a b c"))
+ (should (equal (browse-url-encode-url "\"a\" \"b\"")
+ "\"a%22\"b\""))
+ (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)"))
+ (should (equal (browse-url-encode-url "a$ b$") "a%24b$")))
+
+(ert-deftest browse-url-tests-url-at-point ()
+ (with-temp-buffer
+ (insert "gnu.org")
+ (should (equal (browse-url-url-at-point) "http://gnu.org";))))
+
+(ert-deftest browse-url-tests-file-url ()
+ (should (equal (browse-url-file-url "/foo") "file:///foo"))
+ (should (equal (browse-url-file-url "/foo:") "ftp://foo/";))
+ (should (equal (browse-url-file-url "/ftp@foo:") "ftp://foo/";))
+ (should (equal (browse-url-file-url "/anonymous@foo:")
+ "ftp://foo/";)))
+
+(ert-deftest browse-url-tests-delete-temp-file ()
+ (let ((browse-url-temp-file-name
+ (make-temp-file "browse-url-tests-")))
+ (browse-url-delete-temp-file)
+ (should-not (file-exists-p browse-url-temp-file-name)))
+ (let ((file (make-temp-file "browse-url-tests-")))
+ (browse-url-delete-temp-file file)
+ (should-not (file-exists-p file))))
+
+(ert-deftest browse-url-tests-add-buttons ()
+ (with-temp-buffer
+ (insert "Visit https://gnu.org";)
+ (goto-char (point-min))
+ (browse-url-add-buttons)
+ (goto-char (- (point-max) 1))
+ (should (eq (get-text-property (point) 'face)
+ 'browse-url-button))
+ (should (get-text-property (point) 'browse-url-data))))
+
+(ert-deftest browse-url-tests-button-copy ()
+ (with-temp-buffer
+ (insert "Visit https://gnu.org";)
+ (goto-char (point-min))
+ (browse-url-add-buttons)
+ (should-error (browse-url-button-copy))
+ (goto-char (- (point-max) 1))
+ (browse-url-button-copy)
+ (should (equal (car kill-ring) "https://gnu.org";))))
+
+(provide 'browse-url-tests)
+;;; browse-url-tests.el ends here
diff --git a/test/lisp/net/network-stream-tests.el
b/test/lisp/net/network-stream-tests.el
index 7a98254..cf41615 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -136,7 +136,20 @@
(t
))))
+(defun network-test--resolve-system-name ()
+ (cl-loop for address in (network-lookup-address-info (system-name))
+ when (or (and (= (length address) 5)
+ ;; IPv4 localhost addresses start with 127.
+ (= (elt address 0) 127))
+ (and (= (length address) 9)
+ ;; IPv6 localhost address.
+ (equal address [0 0 0 0 0 0 0 1 0])))
+ return t))
+
(ert-deftest echo-server-with-dns ()
+ (unless (network-test--resolve-system-name)
+ (ert-skip "Can't test resolver for (system-name)"))
+
(let* ((server (make-server (system-name)))
(port (aref (process-contact server :local) 4))
(proc (make-network-process :name "foo"
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index ac24fcf..05196e7 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2001,12 +2001,13 @@ is greater than 10.
(skip-unless (tramp--test-enabled))
;; Multi hops are allowed for inline methods only.
- (should-error
- (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file")
- :type 'user-error)
- (should-error
- (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file")
- :type 'user-error)
+ (let (non-essential)
+ (should-error
+ (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file")
+ :type 'user-error)
+ (should-error
+ (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file")
+ :type 'user-error))
;; Samba does not support file names with periods followed by
;; spaces, and trailing periods or spaces.
@@ -5681,9 +5682,8 @@ This does not support special file names."
(defun tramp--test-sh-p ()
"Check, whether the remote host runs a based method from tramp-sh.el."
- (eq
- (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory)
- 'tramp-sh-file-name-handler))
+ (tramp-sh-file-name-handler-p
+ (tramp-dissect-file-name tramp-test-temporary-file-directory)))
(defun tramp--test-sudoedit-p ()
"Check, whether the sudoedit method is used."
diff --git a/test/lisp/saveplace-resources/saveplace
b/test/lisp/saveplace-resources/saveplace
new file mode 100644
index 0000000..3f3f6d5
--- /dev/null
+++ b/test/lisp/saveplace-resources/saveplace
@@ -0,0 +1,4 @@
+;;; -*- coding: utf-8 -*-
+(("/home/skangas/.emacs.d/cache/recentf" . 1306)
+ ("/home/skangas/wip/emacs/"
+ (dired-filename . "/home/skangas/wip/emacs/COPYING")))
diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el
new file mode 100644
index 0000000..ae7749f
--- /dev/null
+++ b/test/lisp/saveplace-tests.el
@@ -0,0 +1,103 @@
+;;; saveplace-tests.el --- Tests for saveplace.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
+
+;; Author: Stefan Kangas <stefankangas@gmail.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+(require 'ert)
+(require 'saveplace)
+
+(defvar saveplace-tests-dir
+ (file-truename
+ (expand-file-name "saveplace-resources"
+ (file-name-directory (or load-file-name
+ buffer-file-name)))))
+
+(ert-deftest saveplace-test-save-place-to-alist/dir ()
+ (save-place-mode)
+ (let* ((save-place-alist nil)
+ (save-place-loaded t)
+ (loc saveplace-tests-dir))
+ (save-window-excursion
+ (dired loc)
+ (save-place-to-alist)
+ (should (equal save-place-alist
+ `((,(concat loc "/")
+ (dired-filename . ,(concat loc "/saveplace")))))))))
+
+(ert-deftest saveplace-test-save-place-to-alist/file ()
+ (save-place-mode)
+ (let* ((tmpfile (make-temp-file "emacs-test-saveplace-"))
+ (save-place-alist nil)
+ (save-place-loaded t)
+ (loc tmpfile)
+ (pos 4))
+ (unwind-protect
+ (save-window-excursion
+ (find-file loc)
+ (insert "abc") ; must insert something
+ (save-place-to-alist)
+ (should (equal save-place-alist (list (cons tmpfile pos)))))
+ (delete-file tmpfile))))
+
+(ert-deftest saveplace-test-forget-unreadable-files ()
+ (save-place-mode)
+ (let* ((save-place-loaded t)
+ (tmpfile (make-temp-file "emacs-test-saveplace-"))
+ (alist-orig (list (cons "/this/file/does/not/exist" 10)
+ (cons tmpfile 1917)))
+ (save-place-alist alist-orig))
+ (unwind-protect
+ (progn
+ (save-place-forget-unreadable-files)
+ (should (equal save-place-alist (cdr alist-orig))))
+ (delete-file tmpfile))))
+
+(ert-deftest saveplace-test-place-alist-to-file ()
+ (save-place-mode)
+ (let* ((tmpfile (make-temp-file "emacs-test-saveplace-"))
+ (tmpfile2 (make-temp-file "emacs-test-saveplace-"))
+ (save-place-file tmpfile)
+ (save-place-alist (list (cons tmpfile2 99))))
+ (unwind-protect
+ (progn (save-place-alist-to-file)
+ (setq save-place-alist nil)
+ (save-window-excursion
+ (find-file save-place-file)
+ (unwind-protect
+ (should (string-match tmpfile2 (buffer-string)))
+ (kill-buffer))))
+ (delete-file tmpfile)
+ (delete-file tmpfile2))))
+
+(ert-deftest saveplace-test-load-alist-from-file ()
+ (save-place-mode)
+ (let ((save-place-loaded nil)
+ (save-place-file
+ (expand-file-name "saveplace" saveplace-tests-dir))
+ (save-place-alist nil))
+ (load-save-place-alist-from-file)
+ (should (equal save-place-alist
+ '(("/home/skangas/.emacs.d/cache/recentf" . 1306)
+ ("/home/skangas/wip/emacs/"
+ (dired-filename .
"/home/skangas/wip/emacs/COPYING")))))))
+
+(provide 'saveplace-tests)
+;;; saveplace-tests.el ends here
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 8e5cc95..01d1965 100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@ -554,7 +554,8 @@ This checks also `vc-backend' and `vc-responsible-backend'."
(defvar vc-svn-program)
(defun vc-test--svn-enabled ()
- (executable-find vc-svn-program))
+ (and (executable-find "svnadmin")
+ (executable-find vc-svn-program)))
(defun vc-test--sccs-enabled ()
(executable-find "sccs"))
diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el
index 5b01c54..2cfabd1 100644
--- a/test/lisp/wdired-tests.el
+++ b/test/lisp/wdired-tests.el
@@ -143,6 +143,7 @@ wdired-get-filename before and after editing."
(let* ((test-dir (make-temp-file "test-dir-" t))
(server-socket-dir test-dir)
(dired-listing-switches "-Fl")
+ (dired-ls-F-marks-symlinks (eq system-type 'darwin))
(buf (find-file-noselect test-dir)))
(unwind-protect
(progn