summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSean Whitton <spwhitton@spwhitton.name>2022-04-13 16:34:06 -0700
committerSean Whitton <spwhitton@spwhitton.name>2022-04-13 16:34:06 -0700
commit592bf527b6ba756f1009d2c9a4a920808735dde2 (patch)
treefafe217205c1a602f1caa8cf15ee390b887dfbe8
parent233ad93bbc7bc7b57ae61458bddf344980af915f (diff)
parent451eeb512dbfb5ccd4e75eca696a5d4143fec646 (diff)
downloademacs-592bf527b6ba756f1009d2c9a4a920808735dde2.tar.gz
Merge remote-tracking branch 'origin/master' into athena/unstable
-rw-r--r--admin/notes/emba13
-rw-r--r--configure.ac89
-rw-r--r--doc/emacs/anti.texi4
-rw-r--r--doc/emacs/dired.texi22
-rw-r--r--doc/emacs/display.texi5
-rw-r--r--doc/emacs/frames.texi12
-rw-r--r--doc/emacs/maintaining.texi34
-rw-r--r--doc/emacs/mini.texi57
-rw-r--r--doc/emacs/misc.texi7
-rw-r--r--doc/emacs/text.texi11
-rw-r--r--doc/emacs/trouble.texi25
-rw-r--r--doc/lispref/commands.texi90
-rw-r--r--doc/lispref/display.texi24
-rw-r--r--doc/lispref/files.texi6
-rw-r--r--doc/lispref/frames.texi54
-rw-r--r--doc/lispref/functions.texi111
-rw-r--r--doc/lispref/help.texi7
-rw-r--r--doc/lispref/modes.texi97
-rw-r--r--doc/lispref/processes.texi45
-rw-r--r--doc/lispref/text.texi28
-rw-r--r--doc/lispref/variables.texi56
-rw-r--r--doc/misc/eudc.texi73
-rw-r--r--doc/misc/gnus.texi20
-rw-r--r--doc/misc/modus-themes.org536
-rw-r--r--doc/misc/ses.texi38
-rw-r--r--doc/misc/tramp.texi155
-rw-r--r--etc/NEWS267
-rw-r--r--etc/PROBLEMS15
-rw-r--r--etc/themes/modus-operandi-theme.el16
-rw-r--r--etc/themes/modus-themes.el554
-rw-r--r--etc/themes/modus-vivendi-theme.el16
-rw-r--r--leim/Makefile.in1
-rw-r--r--lib-src/ebrowse.c38
-rw-r--r--lib/fcntl.in.h4
-rw-r--r--lib/gnulib.mk.in5
-rw-r--r--lib/mini-gmp-gnulib.c3
-rw-r--r--lib/mini-gmp.c5
-rw-r--r--lib/openat.h2
-rw-r--r--lib/regex_internal.c22
-rw-r--r--lib/regexec.c5
-rw-r--r--lisp/align.el7
-rw-r--r--lisp/arc-mode.el4
-rw-r--r--lisp/auth-source.el45
-rw-r--r--lisp/autoinsert.el16
-rw-r--r--lisp/bindings.el6
-rw-r--r--lisp/bookmark.el19
-rw-r--r--lisp/calendar/appt.el10
-rw-r--r--lisp/color.el2
-rw-r--r--lisp/comint.el2
-rw-r--r--lisp/desktop.el66
-rw-r--r--lisp/dired-aux.el75
-rw-r--r--lisp/dired.el184
-rw-r--r--lisp/dnd.el63
-rw-r--r--lisp/edmacro.el28
-rw-r--r--lisp/emacs-lisp/autoload.el3
-rw-r--r--lisp/emacs-lisp/byte-opt.el11
-rw-r--r--lisp/emacs-lisp/bytecomp.el4
-rw-r--r--lisp/emacs-lisp/cconv.el18
-rw-r--r--lisp/emacs-lisp/cl-generic.el272
-rw-r--r--lisp/emacs-lisp/cl-macs.el58
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el11
-rw-r--r--lisp/emacs-lisp/comp.el12
-rw-r--r--lisp/emacs-lisp/easy-mmode.el76
-rw-r--r--lisp/emacs-lisp/eieio-core.el106
-rw-r--r--lisp/emacs-lisp/eldoc.el13
-rw-r--r--lisp/emacs-lisp/macroexp.el14
-rw-r--r--lisp/emacs-lisp/map-ynp.el10
-rw-r--r--lisp/emacs-lisp/oclosure.el555
-rw-r--r--lisp/emacs-lisp/package.el8
-rw-r--r--lisp/emacs-lisp/pp.el4
-rw-r--r--lisp/emacs-lisp/seq.el15
-rw-r--r--lisp/emacs-lisp/shortdoc.el70
-rw-r--r--lisp/emacs-lisp/subr-x.el32
-rw-r--r--lisp/erc/erc-dcc.el2
-rw-r--r--lisp/erc/erc.el7
-rw-r--r--lisp/eshell/em-basic.el56
-rw-r--r--lisp/eshell/em-cmpl.el23
-rw-r--r--lisp/eshell/em-extpipe.el22
-rw-r--r--lisp/eshell/em-hist.el2
-rw-r--r--lisp/eshell/em-ls.el13
-rw-r--r--lisp/eshell/esh-ext.el2
-rw-r--r--lisp/eshell/esh-util.el51
-rw-r--r--lisp/faces.el8
-rw-r--r--lisp/ffap.el8
-rw-r--r--lisp/files-x.el14
-rw-r--r--lisp/files.el6
-rw-r--r--lisp/finder.el2
-rw-r--r--lisp/font-lock.el91
-rw-r--r--lisp/frame.el64
-rw-r--r--lisp/gnus/gnus-msg.el3
-rw-r--r--lisp/gnus/gnus-search.el142
-rw-r--r--lisp/gnus/gnus-sum.el2
-rw-r--r--lisp/gnus/mail-source.el37
-rw-r--r--lisp/gnus/nnselect.el108
-rw-r--r--lisp/help.el15
-rw-r--r--lisp/hl-line.el18
-rw-r--r--lisp/image-mode.el56
-rw-r--r--lisp/image.el20
-rw-r--r--lisp/image/image-converter.el49
-rw-r--r--lisp/international/iso-transl.el8
-rw-r--r--lisp/international/textsec.el19
-rw-r--r--lisp/isearch.el149
-rw-r--r--lisp/kmacro.el157
-rw-r--r--lisp/ldefs-boot.el440
-rw-r--r--lisp/leim/quail/compose.el6
-rw-r--r--lisp/leim/quail/symbol-ksc.el4
-rw-r--r--lisp/loadup.el5
-rw-r--r--lisp/macros.el91
-rw-r--r--lisp/mail/mail-parse.el3
-rw-r--r--lisp/mail/rmailmm.el17
-rw-r--r--lisp/mail/undigest.el50
-rw-r--r--lisp/menu-bar.el3
-rw-r--r--lisp/minibuffer.el216
-rw-r--r--lisp/mouse.el288
-rw-r--r--lisp/net/browse-url.el21
-rw-r--r--lisp/net/eudc-vars.el64
-rw-r--r--lisp/net/eudc.el161
-rw-r--r--lisp/net/eww.el4
-rw-r--r--lisp/net/shr.el6
-rw-r--r--lisp/net/tramp-adb.el27
-rw-r--r--lisp/net/tramp-archive.el6
-rw-r--r--lisp/net/tramp-crypt.el2
-rw-r--r--lisp/net/tramp-gvfs.el2
-rw-r--r--lisp/net/tramp-integration.el214
-rw-r--r--lisp/net/tramp-rclone.el2
-rw-r--r--lisp/net/tramp-sh.el26
-rw-r--r--lisp/net/tramp-smb.el16
-rw-r--r--lisp/net/tramp-sshfs.el2
-rw-r--r--lisp/net/tramp-sudoedit.el2
-rw-r--r--lisp/net/tramp.el217
-rw-r--r--lisp/org/ol.el2
-rw-r--r--lisp/org/org-clock.el8
-rw-r--r--lisp/org/org-colview.el2
-rw-r--r--lisp/org/org-macro.el2
-rw-r--r--lisp/org/org-macs.el4
-rw-r--r--lisp/org/org-mouse.el2
-rw-r--r--lisp/org/org-table.el2
-rw-r--r--lisp/org/org-version.el2
-rw-r--r--lisp/org/org.el8
-rw-r--r--lisp/pcomplete.el18
-rw-r--r--lisp/pixel-scroll.el37
-rw-r--r--lisp/play/decipher.el13
-rw-r--r--lisp/proced.el47
-rw-r--r--lisp/progmodes/cc-cmds.el12
-rw-r--r--lisp/progmodes/cc-engine.el2
-rw-r--r--lisp/progmodes/grep.el126
-rw-r--r--lisp/progmodes/ruby-mode.el12
-rw-r--r--lisp/progmodes/sh-script.el2
-rw-r--r--lisp/progmodes/sql.el13
-rw-r--r--lisp/progmodes/xref.el4
-rw-r--r--lisp/replace.el70
-rw-r--r--lisp/select.el198
-rw-r--r--lisp/server.el3
-rw-r--r--lisp/ses.el103
-rw-r--r--lisp/shell.el17
-rw-r--r--lisp/simple.el280
-rw-r--r--lisp/subr.el58
-rw-r--r--lisp/tab-bar.el8
-rw-r--r--lisp/term/haiku-win.el180
-rw-r--r--lisp/term/ns-win.el41
-rw-r--r--lisp/term/pc-win.el8
-rw-r--r--lisp/term/pgtk-win.el207
-rw-r--r--lisp/term/w32-win.el1
-rw-r--r--lisp/term/x-win.el49
-rw-r--r--lisp/textmodes/bibtex.el23
-rw-r--r--lisp/thingatpt.el7
-rw-r--r--lisp/thumbs.el9
-rw-r--r--lisp/vc/diff-mode.el43
-rw-r--r--lisp/vc/diff.el14
-rw-r--r--lisp/wdired.el33
-rw-r--r--lisp/x-dnd.el408
-rw-r--r--msdos/sed1v2.inp4
-rw-r--r--src/Makefile.in12
-rw-r--r--src/alloc.c651
-rw-r--r--src/bytecode.c2
-rw-r--r--src/callproc.c53
-rw-r--r--src/coding.c6
-rw-r--r--src/comp.c63
-rw-r--r--src/comp.h4
-rw-r--r--src/data.c56
-rw-r--r--src/decompress.c10
-rw-r--r--src/deps.mk2
-rw-r--r--src/dispextern.h2
-rw-r--r--src/doc.c62
-rw-r--r--src/dynlib.c4
-rw-r--r--src/emacs.c24
-rw-r--r--src/eval.c178
-rw-r--r--src/fileio.c9
-rw-r--r--src/fns.c187
-rw-r--r--src/frame.c48
-rw-r--r--src/frame.h6
-rw-r--r--src/gnutls.c2
-rw-r--r--src/gnutls.h1
-rw-r--r--src/gtkutil.c43
-rw-r--r--src/haiku_font_support.cc6
-rw-r--r--src/haiku_select.cc150
-rw-r--r--src/haiku_support.cc272
-rw-r--r--src/haiku_support.h17
-rw-r--r--src/haikufns.c93
-rw-r--r--src/haikufont.c2
-rw-r--r--src/haikuimage.c7
-rw-r--r--src/haikumenu.c26
-rw-r--r--src/haikuselect.c540
-rw-r--r--src/haikuselect.h24
-rw-r--r--src/haikuterm.c216
-rw-r--r--src/haikuterm.h24
-rw-r--r--src/image.c649
-rw-r--r--src/keyboard.c131
-rw-r--r--src/lisp.h97
-rw-r--r--src/lread.c66
-rw-r--r--src/minibuf.c2
-rw-r--r--src/nsterm.h4
-rw-r--r--src/nsterm.m182
-rw-r--r--src/pdumper.c13
-rw-r--r--src/pgtkfns.c14
-rw-r--r--src/pgtkselect.c28
-rw-r--r--src/pgtkselect.h4
-rw-r--r--src/pgtkterm.c404
-rw-r--r--src/pgtkterm.h83
-rw-r--r--src/print.c6
-rw-r--r--src/process.c74
-rw-r--r--src/sort.c974
-rw-r--r--src/sqlite.c6
-rw-r--r--src/syntax.c2
-rw-r--r--src/syntax.h4
-rw-r--r--src/systime.h1
-rw-r--r--src/termhooks.h29
-rw-r--r--src/thread.c2
-rw-r--r--src/thread.h4
-rw-r--r--src/timefns.c2
-rw-r--r--src/w32image.c1
-rw-r--r--src/w32term.c7
-rw-r--r--src/window.c13
-rw-r--r--src/window.h1
-rw-r--r--src/xdisp.c74
-rw-r--r--src/xfns.c272
-rw-r--r--src/xselect.c36
-rw-r--r--src/xterm.c5266
-rw-r--r--src/xterm.h57
-rw-r--r--src/xwidget.c67
-rw-r--r--test/lisp/color-tests.el14
-rw-r--r--test/lisp/desktop-tests.el50
-rw-r--r--test/lisp/edmacro-tests.el27
-rw-r--r--test/lisp/emacs-lisp/oclosure-tests.el144
-rw-r--r--test/lisp/erc/erc-tests.el59
-rw-r--r--test/lisp/eshell/em-basic-tests.el71
-rw-r--r--test/lisp/eshell/eshell-tests.el8
-rw-r--r--test/lisp/files-x-tests.el18
-rw-r--r--test/lisp/hl-line-tests.el114
-rw-r--r--test/lisp/image-tests.el7
-rw-r--r--test/lisp/international/textsec-tests.el14
-rw-r--r--test/lisp/kmacro-tests.el17
-rw-r--r--test/lisp/mail/undigest-tests.el354
-rw-r--r--test/lisp/net/tramp-tests.el222
-rw-r--r--test/lisp/progmodes/ruby-mode-resources/ruby.rb8
-rw-r--r--test/lisp/replace-tests.el66
-rw-r--r--test/lisp/ses-tests.el75
-rw-r--r--test/src/fns-tests.el113
-rw-r--r--test/src/lread-tests.el22
259 files changed, 17650 insertions, 4652 deletions
diff --git a/admin/notes/emba b/admin/notes/emba
index 99237ea5f63..4c8c27dfeaa 100644
--- a/admin/notes/emba
+++ b/admin/notes/emba
@@ -8,7 +8,8 @@ NOTES FOR EMACS CONTINUOUS BUILD ON EMBA
A continuous build for Emacs can be found at
<https://emba.gnu.org/emacs/emacs>, a Gitlab instance. It watches the
Emacs git repository and starts a pipeline (jobset) if there are new
-changes. This happens for all Emacs branches.
+changes. This happens for all Emacs branches which belong to the
+defined workflow (see below).
* Mail notifications
@@ -32,7 +33,11 @@ The Emacs jobset is defined in the Emacs source tree, file
'test/infra'. They could be adapted for every Emacs branch, see
<https://emba.gnu.org/help/ci/yaml/README.md>.
-A jobset on Gitlab is called pipeline. Emacs pipelines run through
+Only branches whose name starts with 'master', 'emacs', 'feature', or
+'fix' are considered. This is declared in the workflow rules of file
+'test/infra/gitlab-ci.yml'.
+
+A jobset on Gitlab is called a pipeline. Emacs pipelines run through
the stages 'build-images', 'platform-images' and 'native-comp-images'
(create an Emacs instance by 'make bootstrap' with different
configuration parameters) as well as 'normal', 'platforms' and
@@ -41,11 +46,11 @@ configuration parameters) as well as 'normal', 'platforms' and
The jobs for stage 'normal' are contained in the file
'test/infra/test-jobs.yml'. This file is generated by calling 'make
-C test generate-test-jobs' in the Emacs source tree, and the
-resulting file shall be pushed to the Emacs git repository afterwards.
+resulting file should be pushed to the Emacs git repository afterwards.
Every job runs in a Debian docker container. It uses the local clone
of the Emacs git repository to perform a bootstrap and test of Emacs.
-This could happen for several jobs with changed configuration, compile
+This could happen for several jobs with changed configuration, compile,
and test parameters.
The 'build-image-*' jobs of the different '*-images' stages run only
diff --git a/configure.ac b/configure.ac
index bc17935eb13..185e4d08623 100644
--- a/configure.ac
+++ b/configure.ac
@@ -965,6 +965,17 @@ AC_DEFUN([gl_GCC_VERSION_IFELSE],
]
)
+# clang is unduly picky about some things.
+AC_CACHE_CHECK([whether the compiler is clang], [emacs_cv_clang],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[
+ #ifndef __clang__
+ error "not clang";
+ #endif
+ ]])],
+ [emacs_cv_clang=yes],
+ [emacs_cv_clang=no])])
+
AC_ARG_ENABLE([gcc-warnings],
[AS_HELP_STRING([--enable-gcc-warnings@<:@=TYPE@:>@],
[control generation of GCC warnings. The TYPE 'yes'
@@ -984,7 +995,11 @@ AC_ARG_ENABLE([gcc-warnings],
# just a release imported into Git for patch management.
gl_gcc_warnings=no
if test -e "$srcdir"/.git && test ! -f "$srcdir"/.tarball-version; then
- gl_GCC_VERSION_IFELSE([5], [3], [gl_gcc_warnings=warn-only])
+ # Clang typically identifies itself as GCC 4.2 or something similar
+ # even if it is recent enough to accept the warnings we enable.
+ AS_IF([test "$emacs_cv_clang" = yes],
+ [gl_gcc_warnings=warn-only],
+ [gl_GCC_VERSION_IFELSE([5], [3], [gl_gcc_warnings=warn-only])])
fi])
AC_ARG_ENABLE([check-lisp-object-type],
@@ -996,17 +1011,6 @@ if test "$enable_check_lisp_object_type" = yes; then
[Define to enable compile-time checks for the Lisp_Object data type.])
fi
-# clang is unduly picky about some things.
-AC_CACHE_CHECK([whether the compiler is clang], [emacs_cv_clang],
- [AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM([[
- #ifndef __clang__
- error "not clang";
- #endif
- ]])],
- [emacs_cv_clang=yes],
- [emacs_cv_clang=no])])
-
WERROR_CFLAGS=
# When compiling with GCC, prefer -isystem to -I when including system
# include files, to avoid generating useless diagnostics for the files.
@@ -2691,6 +2695,9 @@ if test "${with_webp}" != "no"; then
WEBP_MODULE="libwebp >= $WEBP_REQUIRED"
EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE])
+ if test "$HAVE_WEBP" = "yes"; then
+ WEBP_LIBS="-lwebp -lwebpdemux"
+ fi
AC_SUBST(WEBP_CFLAGS)
AC_SUBST(WEBP_LIBS)
fi
@@ -3357,6 +3364,8 @@ if test "${with_toolkit_scroll_bars}" != "no"; then
AC_DEFINE(USE_TOOLKIT_SCROLL_BARS)
USE_TOOLKIT_SCROLL_BARS=yes
fi
+elif test "${window_system}" != "x11" && "${window_system}" != "none"; then
+ AC_MSG_ERROR(Non-toolkit scroll bars are not implemented for your system)
fi
dnl See if XIM is available.
@@ -3747,6 +3756,14 @@ if test "${HAVE_X11}" = "yes"; then
[Define to 1 if you have the XCB library and X11-XCB library for mixed
X11/XCB programming.])
XCB_LIBS="-lX11-xcb -lxcb -lxcb-util"
+ else
+ AC_CHECK_LIB(xcb-aux, xcb_aux_sync, HAVE_XCB_AUX=yes)
+ if test "${HAVE_XCB_AUX}" = "yes"; then
+ AC_DEFINE(USE_XCB, 1,
+[Define to 1 if you have the XCB library and X11-XCB library for mixed
+ X11/XCB programming.])
+ XCB_LIBS="-lX11-xcb -lxcb -lxcb-aux"
+ fi
fi
fi
fi
@@ -4282,7 +4299,8 @@ if test "${opsys}" = "mingw32"; then
fi
elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \
|| test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \
- || test "${HAVE_BE_APP}" = "yes" || test "$window_system" = "pgtk"; then
+ || test "${HAVE_BE_APP}" = "yes" || test "$window_system" = "pgtk" \
+ && test "${with_gif}" != "no"; then
AC_CHECK_HEADER(gif_lib.h,
# EGifPutExtensionLast only exists from version libungif-4.1.0b1.
# Earlier versions can crash Emacs, but version 5.0 removes EGifPutExtensionLast.
@@ -4538,6 +4556,51 @@ fi
AC_SUBST(XDBE_CFLAGS)
AC_SUBST(XDBE_LIBS)
+### Use the Nonrectangular Window Shape extension if available.
+HAVE_XSHAPE=no
+HAVE_XCB_SHAPE=no
+if test "${HAVE_X11}" = "yes"; then
+ AC_CHECK_HEADER(X11/extensions/shape.h,
+ [AC_CHECK_LIB(Xext, XShapeQueryVersion, HAVE_XSHAPE=yes)],
+ [],
+ [#include <X11/extensions/shape.h>
+ ])
+ if test $HAVE_XSHAPE = yes; then
+ XSHAPE_LIBS=-lXext
+ AC_CHECK_HEADER(xcb/shape.h,
+ [AC_CHECK_LIB(xcb-shape, xcb_shape_combine, HAVE_XCB_SHAPE=yes)], [],
+ [#include <xcb/shape.h>])
+
+ if test $HAVE_XCB_SHAPE = yes && test "$XCB_LIBS" != ""; then
+ XSHAPE_LIBS="$XSHAPE_LIBS -lxcb-shape"
+ AC_DEFINE(HAVE_XCB_SHAPE, 1, [Define to 1 if XCB supports the Nonrectangular Window Shape extension.])
+ fi
+ fi
+ if test $HAVE_XSHAPE = yes; then
+ AC_DEFINE(HAVE_XSHAPE, 1, [Define to 1 if you have the Nonrectangular Window Shape extension.])
+ fi
+fi
+AC_SUBST(XSHAPE_CFLAGS)
+AC_SUBST(XSHAPE_LIBS)
+
+### Use Xcomposite (-lXcomposite) if available
+HAVE_XCOMPOSITE=no
+if test "${HAVE_X11}" = "yes"; then
+ AC_CHECK_HEADER(X11/extensions/Xcomposite.h,
+ [AC_CHECK_LIB(Xcomposite, XCompositeRedirectWindow, HAVE_XCOMPOSITE=yes)],
+ [],
+ [#include <X11/extensions/Xcomposite.h>
+ ])
+ if test $HAVE_XCOMPOSITE = yes; then
+ XCOMPOSITE_LIBS=-lXcomposite
+ fi
+ if test $HAVE_XCOMPOSITE = yes; then
+ AC_DEFINE(HAVE_XCOMPOSITE, 1, [Define to 1 if you have the XCOMPOSITE extension.])
+ fi
+fi
+AC_SUBST(XCOMPOSITE_CFLAGS)
+AC_SUBST(XCOMPOSITE_LIBS)
+
### Use libxml (-lxml2) if available
### mingw32 doesn't use -lxml2, since it loads the library dynamically.
HAVE_LIBXML2=no
diff --git a/doc/emacs/anti.texi b/doc/emacs/anti.texi
index bb88fddc04f..b86037f2a63 100644
--- a/doc/emacs/anti.texi
+++ b/doc/emacs/anti.texi
@@ -31,10 +31,6 @@ back in time. The @code{ftx} font backend is again part of Emacs, for
the same reasons.
@item
-As Motif becomes more and more important with moving farther into the
-past, we've reinstated the code which supports Motif in Emacs.
-
-@item
Emacs once again supports versions 5.3 and older OpenBSD systems,
which will be needed as you move back in time.
diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi
index 3112ac332b3..27df269ce7b 100644
--- a/doc/emacs/dired.texi
+++ b/doc/emacs/dired.texi
@@ -1007,6 +1007,7 @@ subdirectories whose names match @code{grep-find-ignored-directories}.
@findex dired-do-shell-command
@kindex ! @r{(Dired)}
@kindex X @r{(Dired)}
+@vindex dired-confirm-shell-command
The Dired command @kbd{!} (@code{dired-do-shell-command}) reads a
shell command string in the minibuffer, and runs that shell command on
one or more files. The files that the shell command operates on are
@@ -1043,7 +1044,8 @@ list of file names, putting them into one tar file @file{foo.tar}.
If you want to use @samp{*} as a shell wildcard with whitespace around
it, write @samp{*""}. In the shell, this is equivalent to @samp{*};
but since the @samp{*} is not surrounded by whitespace, Dired does not
-treat it specially.
+treat it specially. Emacs will prompt for confirmation if you do
+this, unless @code{dired-confirm-shell-command} is @code{nil}.
@item
Otherwise, if the command string contains @samp{?} surrounded by
@@ -1695,9 +1697,15 @@ directory than in this one. It also marks files with no counterpart,
in both directories, as always.
@cindex drag and drop, Dired
- On the X Window System, Emacs supports the drag and drop
-protocol. You can drag a file object from another program, and drop
-it onto a Dired buffer; this either moves, copies, or creates a link
-to the file in that directory. Precisely which action is taken is
-determined by the originating program. Dragging files out of a Dired
-buffer is currently not supported.
+@vindex dired-mouse-drag-files
+ On the X Window System, Emacs supports the drag and drop protocol.
+You can drag a file object from another program, and drop it onto a
+Dired buffer; this either moves, copies, or creates a link to the file
+in that directory. Precisely which action is taken is determined by
+the originating program. Dragging files out of a Dired buffer is also
+supported, by enabling the user option @code{dired-mouse-drag-files},
+the mouse can be used to drag files onto other programs. When set to
+@code{link}, it will make the other program (typically a file manager)
+create a symbolic link to the file, and setting it to any other
+non-@code{nil} value will make the other program open or create a copy
+of the file.
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 4fcd2a3f7de..534bf5881e7 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -1011,10 +1011,15 @@ in C comments, use this:
@end example
@findex font-lock-remove-keywords
+@vindex font-lock-ignore
@noindent
To remove keywords from the font-lock highlighting patterns, use the
function @code{font-lock-remove-keywords}. @xref{Search-based
Fontification,,, elisp, The Emacs Lisp Reference Manual}.
+Alternatively, you can selectively disable highlighting due to some
+keywords by customizing the @code{font-lock-ignore} option,
+@pxref{Customizing Keywords,,, elisp, The Emacs Lisp Reference
+Manual}.
@cindex just-in-time (JIT) font-lock
@cindex background syntax highlighting
diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi
index 7489344cda9..7c564a87763 100644
--- a/doc/emacs/frames.texi
+++ b/doc/emacs/frames.texi
@@ -1196,6 +1196,18 @@ the variable @code{dnd-open-file-other-window}.
The XDND and Motif drag and drop protocols, and the old KDE 1.x
protocol, are currently supported.
+@vindex dnd-indicate-insertion-point
+@vindex dnd-scroll-margin
+
+ It can be difficult to scroll a window or determine where dropped
+text will be inserted while dragging text onto an Emacs window.
+Setting the option @code{dnd-indicate-insertion-point} to a
+non-@code{nil} value makes point move to the location any dropped text
+will be inserted when the mouse moves in a window during drag, and
+setting @code{dnd-scroll-margin} to an integer value causes a window
+to be scrolled if the mouse moves within that many lines of the top
+or bottom of the window during drag.
+
@vindex mouse-drag-and-drop-region
Emacs can also optionally drag the region with the mouse into
another portion of this or another buffer. To enable that, customize
diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi
index edcc6075f75..37c348d54a9 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -2992,11 +2992,12 @@ etags --language=none \
@findex visit-tags-table
Emacs has at any time at most one @dfn{selected} tags table. All
-the commands for working with tags tables use the selected one. To
-select a tags table, type @kbd{M-x visit-tags-table}, which reads the
-tags table file name as an argument, with @file{TAGS} defaulting to
-the first directory that contains a file named @file{TAGS} encountered
-when recursively searching upward from the default directory.
+the commands for working with tags tables use the selected one first.
+To select a tags table, type @kbd{M-x visit-tags-table}, which reads
+the tags table file name as an argument, with @file{TAGS} defaulting
+to the first directory that contains a file named @file{TAGS}
+encountered when recursively searching upward from the default
+directory.
@vindex tags-file-name
Emacs does not actually read in the tags table contents until you
@@ -3006,16 +3007,25 @@ variable's initial value is @code{nil}; that value tells all the
commands for working with tags tables that they must ask for a tags
table file name to use.
- Using @code{visit-tags-table} when a tags table is already loaded
-gives you a choice: you can add the new tags table to the current list
-of tags tables, or start a new list. The tags commands use all the tags
-tables in the current list. If you start a new list, the new tags table
-is used @emph{instead} of others. If you add the new table to the
-current list, it is used @emph{as well as} the others.
+ In addition to the selected tags table, Emacs maintains the list of
+several tags tables that you use together. For example, if you are
+working on a program that uses a library, you may wish to have the
+tags tables of both the program and the library available, so that
+Emacs could easily find identifiers from both. If the selected tags
+table doesn't have the identifier or doesn't mention the source file a
+tags command needs, the command will try using all the other tags
+tables in the current list of tags tables.
+
+ Using @code{visit-tags-table} to load a new tags table when another
+tags table is already loaded gives you a choice: you can add the new
+tags table to the current list of tags tables, or discard the current
+list and start a new list. If you start a new list, the new tags
+table is used @emph{instead} of others. If you add the new table to
+the current list, it is used @emph{as well as} the others.
@vindex tags-table-list
You can specify a precise list of tags tables by setting the variable
-@code{tags-table-list} to a list of strings, like this:
+@code{tags-table-list} to a list of directory names, like this:
@c keep this on two lines for formatting in smallbook
@example
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index 13d9269c68e..eeb87972cc3 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -624,11 +624,34 @@ completion alternatives in the completion list.
@vindex completion-auto-help
If @code{completion-auto-help} is set to @code{nil}, the completion
commands never display the completion list buffer; you must type
-@kbd{?} to display the list. If the value is @code{lazy}, Emacs only
+@kbd{?} to display the list. If the value is @code{lazy}, Emacs only
shows the completion list buffer on the second attempt to complete.
In other words, if there is nothing to complete, the first @key{TAB}
echoes @samp{Next char not unique}; the second @key{TAB} shows the
-completion list buffer.
+completion list buffer. If the value is @code{always}, the completion
+list buffer is always shown when completion is attempted.
+
+The display of the completion list buffer after it is shown for the
+first time is also controlled by @code{completion-auto-help}. If the
+value is @code{t} or @code{lazy}, the window showing the completions
+pops down when Emacs is able to complete (and may pop up again if
+Emacs is again unable to complete after you type some more text); if
+the value is @code{always}, the window pops down only when you exit
+the completion. The value @code{visible} is a hybrid: it behaves like
+@code{t} when it decides whether to pop up the window showing the
+completion list buffer, and like @code{always} when it decides whether
+to pop it down.
+
+@vindex completion-auto-select
+ Emacs can optionally select the window showing the completions when
+it shows that window. To enable this behavior, customize the user
+option @code{completion-auto-select} to @code{t}, which changes the
+behavior of @key{TAB} when Emacs pops up the completions: pressing
+@kbd{@key{TAB}} will switch to the completion list buffer, and you can
+then move to a candidate by cursor motion commands and select it with
+@kbd{@key{RET}}. If the value of @code{completion-auto-select} is
+@code{second-tab}, then the first @kbd{@key{TAB}} will pop up the
+completions list buffer, and the second one will switch to it.
@vindex completion-cycle-threshold
If @code{completion-cycle-threshold} is non-@code{nil}, completion
@@ -651,6 +674,36 @@ changed by changing the @code{completions-format} user option. If
@code{vertical}, sort the completions vertically in columns instead,
and if @code{one-column}, just use a single column.
+@vindex completions-max-height
+ When @code{completions-max-height} is non-@code{nil}, it limits the
+size of the completions window. It is specified in lines and include
+mode, header line and a bottom divider, if any. For a more complex
+control of the Completion window display properties, you can use
+@code{display-buffer-alist} (@pxref{Buffer Display Action
+Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp
+Reference Manual}).
+
+@vindex completions-header-format
+The variable @code{completions-header-format} is a format spec string to
+control the informative line shown before the completions list of
+candidates. If it contains a @samp{%s} construct, that get replaced
+by the number of completions shown in the completion list buffer. To
+suppress the display of the heading line, customize this variable to
+@code{nil}. The string that is the value of this variable can have
+text properties to change the visual appearance of the heading line;
+some useful properties @code{face} or @code{cursor-intangible}
+(@pxref{Special Properties,,Properties with Special Meanings, elisp,
+The Emacs Lisp Reference Manual}).
+
+@vindex completions-highlight-face
+When @code{completions-highlight-face} names a face, the current
+completion candidate, the one that will be selected by typing
+@kbd{@key{RET}} or clicking the mouse, will be highlighted using that
+face. The default value of this variable is
+@code{completions-highlight}; the value is @code{nil} disables this
+highlighting. This feature uses the special text property
+@code{cursor-face}.
+
@node Minibuffer History
@section Minibuffer History
@cindex minibuffer history
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index 4710c05b620..a0d79711f10 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -2770,7 +2770,12 @@ will by default ask you whether to use the locked desktop file. You
can avoid the question by customizing the variable
@code{desktop-load-locked-desktop} to either @code{nil}, which means
never load the desktop in this case, or @code{t}, which means load the
-desktop without asking.
+desktop without asking. Finally, the @code{check-pid} value means to
+load the file if the Emacs process that has locked the desktop is not
+running on the local machine. This should not be used in
+circumstances where the locking Emacs might still be running on
+another machine. This could be the case in multi-user environments
+where your home directory is mounted remotely using NFS or similar.
@cindex desktop restore in daemon mode
When Emacs starts in daemon mode, it cannot ask you any questions,
diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi
index 9f152f1cc14..fa8eaf09245 100644
--- a/doc/emacs/text.texi
+++ b/doc/emacs/text.texi
@@ -1259,6 +1259,17 @@ and related functions treat hidden text, @pxref{Query Replace}.)
You can also automatically make text visible as you navigate in it by
using Reveal mode (@kbd{M-x reveal-mode}), a buffer-local minor mode.
+@vindex outline-default-state
+ The @code{outline-default-state} variable controls what headings
+will be visible after Outline mode is turned on. If non-@code{nil},
+some headings are initially outlined. If equal to a number, show only
+headings up to and including the corresponding level. If equal to
+@code{outline-show-all}, all text of buffer is shown. If equal to
+@code{outline-show-only-headings}, show only headings, whatever their
+level is. If equal to a lambda function or function name, this
+function is expected to toggle headings visibility, and will be called
+without arguments after the mode is enabled.
+
@node Outline Views
@subsection Viewing One Outline in Multiple Views
diff --git a/doc/emacs/trouble.texi b/doc/emacs/trouble.texi
index 93f9c779dbf..8da96de1cb4 100644
--- a/doc/emacs/trouble.texi
+++ b/doc/emacs/trouble.texi
@@ -296,6 +296,31 @@ editing in the same Emacs session.
out of memory, because the Buffer Menu needs a fair amount of memory
itself, and the reserve supply may not be enough.
+@cindex out of memory killer, GNU/Linux
+@cindex OOM killer
+ On GNU/Linux systems, Emacs does not normally get notified about
+out-of-memory situations; instead, the OS can kill the Emacs process
+when it runs out of memory. This feature is known as the
+@dfn{out-of-memory killer}, or @dfn{@acronym{OOM} killer}. When this
+behavior is in effect, Emacs is unable to detect the out-of-memory
+situation in time, and won't be able to let you save your buffer as
+described above. However, it is possible to turn off this behavior of
+the OS, and thus allow Emacs a chance to handle the out-of-memory
+situation in a more useful manner, before it is killed. To do that,
+become the super user, edit the file @code{/etc/sysctl.conf} to
+contain the lines shown below, and then invoke the command
+@w{@kbd{sysctl -p}} from the shell prompt:
+
+@example
+vm.overcommit_memory=2
+vm.overcommit_ratio=0
+@end example
+
+@noindent
+Please note that the above setting affects all the processes on the
+system, and in general the behavior of the system under memory
+pressure, not just the Emacs process alone.
+
@node Crashing
@subsection When Emacs Crashes
diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index a4ae68af5b2..ace0c025512 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -1127,6 +1127,96 @@ frame, the value is the frame to which the event was redirected.
If the last event came from a keyboard macro, the value is @code{macro}.
@end defvar
+@cindex input devices
+@cindex device names
+Input events must come from somewhere; sometimes, that is a keyboard
+macro, a signal, or `unread-command-events', but it is usually a
+physical input device connected to a computer that is controlled by
+the user. Those devices are referred to as @dfn{input devices}, and
+Emacs associates each input event with the input device from which it
+originated. They are identified by a name that is unique to each
+input device.
+
+The ability to determine the precise input device used depends on the
+details of each system. When that information is unavailable, Emacs
+reports keyboard events as originating from the @samp{"Virtual core
+keyboard"}, and other events as originating from the @samp{"Virtual
+core pointer"}. (These values are used on every platform because the
+X server reports them when detailed device information is not known.)
+
+@defvar last-event-device
+This variable records the name of the input device from which the last
+input event read was generated. It is @code{nil} if no such device
+exists, i.e., the last input event was read from
+@code{unread-command-events}, or it came from a keyboard macro.
+
+When the X Input Extension is being used on X Windows, the device name
+is a string that is unique to each physical keyboard, pointing device
+and touchscreen attached to the X server. Otherwise, it is either the
+string @samp{"Virtual core pointer"} or @samp{"Virtual core
+keyboard"}, depending on whether the event was generated by a pointing
+device (such as a mouse) or a keyboard.
+@end defvar
+
+@defun device-class frame name
+There are various different types of devices, which can be determined
+from their names. This function can be used to determined the correct
+type of the device @var{name} for an event originating from
+@var{frame}.
+
+The return value is one of the following symbols (``device classes''):
+
+@table @code
+@item core-keyboard
+The core keyboard; this is means the device is a keyboard-like device,
+but no other characteristics are unknown.
+
+@item core-pointer
+The core pointer; this means the device is a pointing device, but no
+other characteristics are known.
+
+@item mouse
+A computer mouse.
+
+@item trackpoint
+A trackpoint or joystick (or other similar control.)
+
+@item eraser
+The other end of a stylus on a graphics tablet, or a standalone
+eraser.
+
+@item pen
+The pointed end of a pen on a graphics tablet, a stylus, or some other
+similar device.
+
+@item puck
+A device that looks like a computer mouse, but reports absolute
+coordinates relative to some other surface.
+
+@item power-button
+A power button or volume button (or other similar control.)
+
+@item keyboard
+A computer keyboard.
+
+@item touchscreen
+A computer touchpad.
+
+@item pad
+A collection of sensitive buttons, rings, and strips commonly found
+around a drawing tablet.
+
+@item touchpad
+An indirect touch device such as a touchpad.
+
+@item piano
+A musical instrument such as an electronic keyboard.
+
+@item test
+A device used by the XTEST extension to report input.
+@end table
+@end defun
+
@node Adjusting Point
@section Adjusting Point After Commands
@cindex adjusting point
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 95e00e140da..2dc0ef4c0ba 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -4642,14 +4642,15 @@ about to be executed. This feature has nothing to do with
@defvar overlay-arrow-string
This variable holds the string to display to call attention to a
particular line, or @code{nil} if the arrow feature is not in use.
-On a graphical display the contents of the string are ignored; instead a
-glyph is displayed in the fringe area to the left of the display area.
+On a graphical display the contents of the string are ignored if the
+left fringe is shown; instead a glyph is displayed in the fringe area
+to the left of the display area.
@end defvar
@defvar overlay-arrow-position
This variable holds a marker that indicates where to display the overlay
arrow. It should point at the beginning of a line. On a non-graphical
-display the arrow text
+display, or when the left fringe is not shown, the arrow text
appears at the beginning of that line, overlaying any text that would
otherwise appear. Since the arrow is usually short, and the line
usually begins with indentation, normally nothing significant is
@@ -4681,11 +4682,12 @@ this list.
Each variable on this list can have properties
@code{overlay-arrow-string} and @code{overlay-arrow-bitmap} that
-specify an overlay arrow string (for text terminals) or fringe bitmap
-(for graphical terminals) to display at the corresponding overlay
-arrow position. If either property is not set, the default
-@code{overlay-arrow-string} or @code{overlay-arrow} fringe indicator
-is used.
+specify an overlay arrow string (for text terminals or graphical
+terminals without the left fringe shown) or fringe bitmap
+(for graphical terminals with a left fringe) to display at the
+corresponding overlay arrow position. If either property is not set,
+the default @code{overlay-arrow-string} or @code{overlay-arrow} fringe
+indicator is used.
@node Scroll Bars
@@ -5505,6 +5507,12 @@ symbol}. The symbols for the above formats are, respectively,
@code{pbm}, @code{xbm}, @code{xpm}, @code{gif}, @code{jpeg},
@code{tiff}, @code{png}, @code{svg}, and @code{webp}.
+ On some platforms, the built-in image support that doesn't require
+any optional libraries includes BMP images.@footnote{
+On MS-Windows, this requires @code{w32-use-native-image-API} to be set
+non-@code{nil}.
+}
+
Furthermore, if you build Emacs with ImageMagick
(@code{libMagickWand}) support, Emacs can display any image format
that ImageMagick can. @xref{ImageMagick Images}. All images
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 6e59e87d286..d8b55b114ae 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -3344,6 +3344,7 @@ first, before handlers for jobs such as remote file access.
@code{get-file-buffer},
@code{insert-directory},
@code{insert-file-contents},@*
+@code{list-system-processes},
@code{load}, @code{lock-file},
@code{make-auto-save-file-name},
@code{make-directory},
@@ -3352,7 +3353,7 @@ first, before handlers for jobs such as remote file access.
@code{make-nearby-temp-file},
@code{make-process},
@code{make-symbolic-link},@*
-@code{process-file},
+@code{process-attributes}, @code{process-file},
@code{rename-file}, @code{set-file-acl}, @code{set-file-modes},
@code{set-file-selinux-context}, @code{set-file-times},
@code{set-visited-file-modtime}, @code{shell-command},
@@ -3405,6 +3406,7 @@ first, before handlers for jobs such as remote file access.
@code{get-file-buffer},
@code{insert-directory},
@code{insert-file-contents},
+@code{list-system-processes},
@code{load}, @code{lock-file},
@code{make-auto-save-file-name},
@code{make-direc@discretionary{}{}{}tory},
@@ -3413,7 +3415,7 @@ first, before handlers for jobs such as remote file access.
@code{make-nearby-temp-file},
@code{make-process},
@code{make-symbolic-link},
-@code{process-file},
+@code{process-attributes}, @code{process-file},
@code{rename-file}, @code{set-file-acl}, @code{set-file-modes},
@code{set-file-selinux-context}, @code{set-file-times},
@code{set-visited-file-modtime}, @code{shell-command},
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index 31ebeb51b41..05c6e4b719b 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -3512,10 +3512,18 @@ enabled. Typically, @var{body} would use @code{read-event} to read
the motion events and modify the display accordingly. @xref{Motion
Events}, for the format of mouse motion events.
-The value of @code{track-mouse} is that of the last form in @var{body}.
-You should design @var{body} to return when it sees the up-event that
-indicates the release of the button, or whatever kind of event means
-it is time to stop tracking.
+The value of @code{track-mouse} is that of the last form in
+@var{body}. You should design @var{body} to return when it sees the
+up-event that indicates the release of the button, or whatever kind of
+event means it is time to stop tracking. Its value also controls how
+mouse events are reported while a mouse button is held down: if it is
+@code{dropping} or @code{drag-source}, the motion events are reported
+relative to the frame underneath the pointer. If there is no such
+frame, the events will be reported relative to the frame the mouse
+buttons were first pressed on. In addition, the @code{posn-window} of
+the mouse position list will be @code{nil} if the value is
+@code{drag-source}. This is useful to determine if a frame is not
+directly visible underneath the mouse pointer.
The @code{track-mouse} form causes Emacs to generate mouse motion
events by binding the variable @code{track-mouse} to a
@@ -3918,11 +3926,11 @@ upper-case names, in accord with X Window System conventions. If
@var{type} is @code{nil}, that stands for @code{PRIMARY}.
If @var{data} is @code{nil}, it means to clear out the selection.
-Otherwise, @var{data} may be a string, a symbol, an integer (or a cons
-of two integers or list of two integers), an overlay, or a cons of two
-markers pointing to the same buffer. An overlay or a pair of markers
-stands for text in the overlay or between the markers. The argument
-@var{data} may also be a vector of valid non-vector selection values.
+Otherwise, @var{data} may be a string, a symbol, an integer, an
+overlay, or a cons of two markers pointing to the same buffer. An
+overlay or a pair of markers stands for text in the overlay or between
+the markers. The argument @var{data} may also be a vector of valid
+non-vector selection values.
This function returns @var{data}.
@end deffn
@@ -4042,12 +4050,13 @@ you want to alter Emacs behavior, you can customize these variables.
On capable window systems, Emacs also supports dragging contents
from its frames to windows of other applications.
-@defun x-begin-drag targets &optional action frame return-frame
+@defun x-begin-drag targets &optional action frame return-frame allow-current-frame
This function begins a drag from @var{frame}, and returns when the
drag-and-drop operation ends, either because the drop was successful,
or because the drop was rejected. The drop occurs when all mouse
buttons are released on top of an X window other than @var{frame} (the
-@dfn{drop target}).
+@dfn{drop target}), or any X window if @var{allow-current-frame} is
+non-@code{nil}.
@var{targets} is a list of strings describing selection targets, much
like the @var{data-type} argument to @code{gui-get-selection}, that
@@ -4061,16 +4070,29 @@ the drop target; or @code{XdndActionMove}, which means copy as with
@code{XdndActionCopy}, and in addition the caller should delete
whatever was stored in that selection after copying it.
-If @var{return-frame} is non-nil and the mouse moves over an Emacs
-frame after first moving out of @var{frame}, then the frame to which
-the mouse moves will be returned immediately. This is useful when you
+@var{action} may also be an alist which associates between symbols
+describing the available actions, and strings that the drop target is
+expected to present to the user to choose between the available
+actions.
+
+If @var{return-frame} is non-@code{nil} and the mouse moves over an
+Emacs frame after first moving out of @var{frame}, then the frame to
+which the mouse moves will be returned immediately. If
+@var{return-frame} is the symbol @code{now}, then any frame underneath
+the mouse pointer will be returned without waiting for the mouse to
+first move out of @var{frame}. @var{return-frame} is useful when you
want to treat dragging content from one frame to another specially,
-while also being able to drag content to other programs.
+while also being able to drag content to other programs, but it is not
+guaranteed to work on all systems and with all window managers.
If the drop was rejected or no drop target was found, this function
returns @code{nil}. Otherwise, it returns a symbol describing the
action the target chose to perform, which can differ from @var{action}
-if that isn't supported by the drop target.
+if that isn't supported by the drop target. @code{XdndActionPrivate}
+is also a valid return value in addition to @code{XdndActionCopy} and
+@code{XdndActionMove}; it means that the drop target chose to perform
+an unspecified action, and no further processing is required by the
+caller.
@end defun
@node Color Names
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index 207919ea645..70337d4c4a8 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -22,6 +22,7 @@ define them.
* Function Cells:: Accessing or setting the function definition
of a symbol.
* Closures:: Functions that enclose a lexical environment.
+* OClosures:: Function objects
* Advising Functions:: Adding to the definition of a function.
* Obsolete Functions:: Declaring functions obsolete.
* Inline Functions:: Functions that the compiler will expand inline.
@@ -1509,6 +1510,116 @@ exposed to the rest of the Lisp world is considered an internal
implementation detail. For this reason, we recommend against directly
examining or altering the structure of closure objects.
+@node OClosures
+@section Open Closures
+
+Traditionally, functions are opaque objects which offer no other
+functionality but to call them. Emacs Lisp functions aren't fully
+opaque since you can extract some info out of them such as their
+docstring, their arglist, or their interactive spec, but they are
+mostly opaque. This is usually what we want, but occasionally we need
+functions to expose a bit more information about themselves.
+
+OClosures are functions which carry additional type information,
+and expose some information in the form of slots which you can access
+via accessor functions.
+
+They are defined in two steps: first @code{oclosure-define} is used to
+define new OClosure types by specifying the slots carried by those
+OClosures, and then @code{oclosure-lambda} is used to create an
+OClosure object of a given type.
+
+Say we want to define keyboard macros, i.e. interactive functions
+which re-execute a sequence of key events. You could do it with
+a plain function as follows:
+@example
+(defun kbd-macro (key-sequence)
+ (lambda (&optional arg)
+ (interactive "P")
+ (execute-kbd-macro key-sequence arg)))
+@end example
+But with such a definition there is no easy way to extract the
+@var{key-sequence} from that function, for example to print it.
+
+We can solve this problem using OClosures as follows. First we define
+the type of our keyboard macros (to which we decided to add
+a @code{counter} slot while at it):
+@example
+(oclosure-define kbd-macro
+ "Keyboard macro."
+ keys (counter :mutable t))
+@end example
+After which we can rewrite our @code{kbd-macro} function:
+@example
+(defun kbd-macro (key-sequence)
+ (oclosure-lambda (kbd-macro (keys key-sequence) (counter 0))
+ (&optional arg)
+ (interactive "p")
+ (execute-kbd-macro keys arg)
+ (setq counter (1+ counter))))
+@end example
+As you can see, the @code{keys} and @code{counter} slots of the
+OClosure can be accessed as local variables from within the body
+of the OClosure. But we can now also access them from outside of the
+body of the OClosure, for example to describe a keyboard macro:
+@example
+(defun describe-kbd-macro (km)
+ (if (not (eq 'kbd-macro (oclosure-type km)))
+ (message "Not a keyboard macro")
+ (let ((keys (kbd-macro--keys km))
+ (counter (kbd-macro--counter km)))
+ (message "Keys=%S, called %d times" keys counter))))
+@end example
+Where @code{kbd-macro--keys} and @code{kbd-macro--counter} are
+accessor functions generated by the @code{oclosure-define} macro.
+
+@defmac oclosure-define name &optional docstring &rest slots
+This macro defines a new OClosure type along with accessor functions
+for its slots. @var{name} can be a symbol (the name of
+the new type), or a list of the form @code{(@var{name} . @var{type-props})} in
+which case @var{type-props} is a list of additional properties.
+@var{slots} is a list of slot descriptions where each slot can be
+either a symbol (the name of the slot) or it can be of the form
+@code{(@var{slot-name} . @var{slot-props})} where @var{slot-props} is
+a property list.
+
+For each slot, the macro creates an accessor function named
+@code{@var{name}--@var{slot-name}}. By default slots are immutable.
+If you need a slot to be mutable, you need to specify it with the
+@code{:mutable} slot property, after which it can be mutated for
+example with @code{setf}.
+
+Beside slot accessors, the macro can create a predicate and
+functional update functions according to @var{type-props}:
+a @code{(:predicate @var{pred-name})} in the @var{type-props} causes
+the definition of a predicate function under the name @var{pred-name},
+and @code{(:copier @var{copier-name} @var{copier-arglist})} causes the
+definition of a functional update function which takes an OClosure of
+type @var{name} as first argument and returns a copy of it with the
+slots named in @var{copier-arglist} modified to the value passed in the
+corresponding argument.
+@end defmac
+
+@defmac oclosure-lambda (type . slots) arglist &rest body
+This macro creates an anonymous OClosure of type @var{type}.
+@var{slots} should be a list of elements of the form @code{(@var{slot-name}
+@var{exp})}.
+At run time, each @var{exp} is evaluated, in order, after which
+the OClosure is created with its slots initialized with the
+resulting values.
+
+When called as a function, the OClosure will accept arguments
+according to @var{arglist} and will execute the code in @var{body}.
+@var{body} can refer to the value of any of its slot directly as if it
+were a local variable that had been captured by static scoping.
+@end defmac
+
+@defun oclosure-type object
+This function returns the OClosure type (a symbol) of @var{object} if it is an
+OClosure, and nil otherwise.
+@end defun
+
+
@node Advising Functions
@section Advising Emacs Lisp Functions
@cindex advising functions
diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi
index 10a12940a15..d53bfad8e9e 100644
--- a/doc/lispref/help.texi
+++ b/doc/lispref/help.texi
@@ -158,6 +158,13 @@ the function definition has no documentation string. In that case,
@code{documentation} returns @code{nil}.
@end defun
+@defun function-documentation function
+Generic function used by @code{documentation} to extract the raw
+docstring from a function object. You can specify how to get the
+docstring of a specific function type by adding a corresponding method
+to it.
+@end defun
+
@defun face-documentation face
This function returns the documentation string of @var{face} as a
face.
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index c29936d5caa..ff09a787490 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -3204,7 +3204,9 @@ Non-@code{nil} means that regular expression matching for the sake of
You can use @code{font-lock-add-keywords} to add additional
search-based fontification rules to a major mode, and
-@code{font-lock-remove-keywords} to remove rules.
+@code{font-lock-remove-keywords} to remove rules. You can also
+customize the @code{font-lock-ignore} option to selectively disable
+fontification rules for keywords that match certain criteria.
@defun font-lock-add-keywords mode keywords &optional how
This function adds highlighting @var{keywords}, for the current buffer
@@ -3274,6 +3276,99 @@ mode @emph{and} all modes derived from it, do this instead:
font-lock-keyword-face)))))
@end smallexample
+@defopt font-lock-ignore
+@cindex selectively disabling font-lock fontifications
+This option defines conditions for selectively disabling
+fontifications due to certain Font Lock keywords. If non-@code{nil},
+its value is a list of elements of the following form:
+
+@example
+(@var{symbol} @var{condition} @dots{})
+@end example
+
+Here, @var{symbol} is a symbol, usually a major or minor mode. The
+subsequent @var{condition}s of a @var{symbol}'s list element will be in
+effect if @var{symbol} is bound and its value is non-@code{nil}. For
+a mode's symbol, it means that the current major mode is derived from
+that mode, or that minor mode is enabled in the buffer. When a
+@var{condition} is in effect, any fontifications caused by
+@code{font-lock-keywords} elements that match the @var{condition} will
+be disabled.
+
+Each @var{condition} can be one of the following:
+
+@table @asis
+@item a symbol
+This condition matches any element of Font Lock keywords that
+references the symbol. This is usually a face, but can be any symbol
+referenced by an element of the @code{font-lock-keywords} list. The
+symbol can contain wildcards: @code{*} matches any string in the
+symbol'ss name, @code{?} matches a single character, and
+@code{[@var{char-set}]}, where @var{char-set} is a string of one or
+more characters, matches a single character from the set.
+
+@item a string
+This condition matches any element of Font Lock keywords whose
+@var{matcher} is a regexp which matches the string. In other words,
+this condition matches a Font Lock rule which highlights the string.
+Thus, the string could be a specific program keyword whose
+highlighting you want to disable.
+
+@item @code{(pred @var{function})}
+This condition matches any element of Font Lock keywords for which
+@var{function}, when called with the element as the argument, returns
+non-@code{nil}.
+
+@item @code{(not @var{condition})}
+This matches if @var{condition} doesn’t.
+
+@item @code{(and @var{condition} @dots{})}
+This matches if each of the @var{condition}s matches.
+
+@item @code{(or @var{condition} @dots{})}
+This matches if at least one of the @var{condition}s matches.
+
+@item @code{(except @var{condition})}
+This condition can only be used at top level or inside an
+@code{or} clause. It undoes the effect of a previously matching
+condition on the same level.
+@end table
+@end defopt
+
+As an example, consider the following setting:
+
+@smallexample
+(setq font-lock-ignore
+ '((prog-mode font-lock-*-face
+ (except help-echo))
+ (emacs-lisp-mode (except ";;;###autoload)")
+ (whitespace-mode whitespace-empty-at-bob-regexp)
+ (makefile-mode (except *))))
+@end smallexample
+
+Line by line, this does the following:
+
+@enumerate
+@item
+In all programming modes, disable fontifications due to all font-lock
+keywords that apply one of the standard font-lock faces (excluding
+strings and comments, which are covered by syntactic Font Lock).
+
+@item
+However, keep any keywords that add a @code{help-echo} text property.
+
+@item
+In Emacs Lisp mode, also keep the highlighting of autoload cookies,
+which would have been excluded by the first condition.
+
+@item
+When @code{whitespace-mode} (a minor mode) is enabled, also don't
+highlight an empty line at beginning of buffer.
+
+@item
+Finally, in Makefile mode, don't apply any conditions.
+@end enumerate
+
@node Other Font Lock Variables
@subsection Other Font Lock Variables
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index ed07c1cbf70..18f446735bb 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -197,7 +197,7 @@ gives special treatment to certain characters, and if these characters
occur in the file name, they will confuse the shell. To handle these
characters, use the function @code{shell-quote-argument}:
-@defun shell-quote-argument argument
+@defun shell-quote-argument argument &optional posix
This function returns a string that represents, in shell syntax,
an argument whose actual contents are @var{argument}. It should
work reliably to concatenate the return value into a shell command
@@ -227,6 +227,15 @@ a shell command:
" "
(shell-quote-argument newfile))
@end example
+
+If the optional @var{posix} argument is non-@code{nil}, @var{argument}
+is quoted according to POSIX shell quoting rules, regardless of the
+system’s shell. This is useful when your shell could run on a remote
+host, which requires a POSIX shell in general.
+
+@example
+(shell-quote-argument "foo > bar" (file-remote-p default-directory))
+@end example
@end defun
@cindex quoting and unquoting command-line arguments
@@ -1463,7 +1472,7 @@ incoming data from the connection. For serial connections, data that
arrived during the time the process was stopped might be lost.
@end defun
-@deffn Command signal-process process signal
+@deffn Command signal-process process signal &optional remote
This function sends a signal to process @var{process}. The argument
@var{signal} specifies which signal to send; it should be an integer,
or a symbol whose name is a signal.
@@ -1471,12 +1480,18 @@ or a symbol whose name is a signal.
The @var{process} argument can be a system process @acronym{ID} (an
integer); that allows you to send signals to processes that are not
children of Emacs. @xref{System Processes}.
+
+If @var{process} is a process object which contains the property
+@code{remote-pid}, or @var{process} is a number and @var{remote} is a
+remote file name, @var{process} is interpreted as process on the
+respective remote host, which will be the process to signal.
@end deffn
Sometimes, it is necessary to send a signal to a non-local
asynchronous process. This is possible by writing an own
-@code{interrupt-process} implementation. This function must be added
-then to @code{interrupt-process-functions}.
+@code{interrupt-process} or @code{signal-process} implementation.
+This function must be added then to @code{interrupt-process-functions}
+or @code{signal-process-functions}, respectively.
@defvar interrupt-process-functions
This variable is a list of functions to be called for
@@ -1489,6 +1504,17 @@ default function, which shall always be the last in this list, is
This is the mechanism, how Tramp implements @code{interrupt-process}.
@end defvar
+@defvar signal-process-functions
+This variable is a list of functions to be called for
+@code{signal-process}. The arguments of the functions are the same as
+for @code{signal-process}. These functions are called in the order of
+the list, until one of them returns non-@code{nil}. The default
+function, which shall always be the last in this list, is
+@code{signal-default-interrupt-process}.
+
+This is the mechanism, how Tramp implements @code{signal-process}.
+@end defvar
+
@node Output from Processes
@section Receiving Output from Processes
@cindex process output
@@ -2232,9 +2258,8 @@ query flag of all processes is ignored.
In addition to accessing and manipulating processes that are
subprocesses of the current Emacs session, Emacs Lisp programs can
-also access other processes running on the same machine. We call
-these @dfn{system processes}, to distinguish them from Emacs
-subprocesses.
+also access other processes. We call these @dfn{system processes}, to
+distinguish them from Emacs subprocesses.
Emacs provides several primitives for accessing system processes.
Not all platforms support these primitives; on those which don't,
@@ -2246,6 +2271,9 @@ system. Each process is identified by its @acronym{PID}, a numerical
process ID that is assigned by the OS and distinguishes the process
from all the other processes running on the same machine at the same
time.
+
+If @code{default-directory} points to a remote host, processes of that
+host are returned.
@end defun
@defun process-attributes pid
@@ -2257,6 +2285,9 @@ attribute @var{key}s that this function can return are listed below.
Not all platforms support all of these attributes; if an attribute is
not supported, its association will not appear in the returned alist.
+If @code{default-directory} points to a remote host, @var{pid} is
+regarded as process of that host.
+
@table @code
@item euid
The effective user ID of the user who invoked the process. The
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 7897adeb053..ab9abd0495b 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -3541,16 +3541,30 @@ special modes that implement their own highlighting.
@item mouse-face
@kindex mouse-face @r{(text property)}
-This property is used instead of @code{face} when the mouse is on or
-near the character. For this purpose, ``near'' means that all text
-between the character and where the mouse is have the same
-@code{mouse-face} property value.
+This property is used instead of @code{face} when the mouse pointer
+hovers over the text which has this property. When this happens, the
+entire stretch of text that has the same @code{mouse-face} property
+value, not just the character under the mouse, is highlighted.
Emacs ignores all face attributes from the @code{mouse-face} property
that alter the text size (e.g., @code{:height}, @code{:weight}, and
@code{:slant}). Those attributes are always the same as for the
unhighlighted text.
+@item cursor-face
+@kindex cursor-face @r{(text property)}
+@findex cursor-face-highlight-mode
+@vindex cursor-face-highlight-nonselected-window
+This property is similar to @code{mouse-face}, but it is used when
+point (not the mouse) is inside text that has this property. The
+highlighting happens only if the mode
+@code{cursor-face-highlight-mode} is enabled. When the variable
+@code{cursor-face-highlight-nonselected-window} is non-@code{nil}, the
+text with this face is highlighted even if the window is not selected,
+similarly to what @code{highlight-nonselected-windows} does for the
+region (@pxref{Mark,, The Mark and the Region, emacs, The GNU Emacs
+Manual}).
+
@item fontified
@kindex fontified @r{(text property)}
This property says whether the text is ready for display. If
@@ -5394,6 +5408,12 @@ Extensions are usually shared-library files; on GNU and Unix systems,
they have the @file{.so} file-name extension.
@end defun
+@findex sqlite-mode-open-file
+If you wish to list the contents of an SQLite file, you can use the
+@code{sqlite-mode-open-file} command. This will pop to a buffer using
+@code{sqlite-mode}, which allows you to examine (and alter) the
+contents of an SQLite database.
+
@node Parsing HTML/XML
@section Parsing HTML and XML
@cindex parsing html
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index d991ae9e277..f0e3f337a69 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -2295,6 +2295,21 @@ list in @var{variables} is an alist of the form
'((null-device . "/dev/null")))
@end group
@end example
+
+@findex connection-local-get-profile-variables
+If you want to append variable settings to an existing profile, you
+could use the function @code{connection-local-get-profile-variables}
+in order to retrieve the existing settings, like
+
+@example
+@group
+(connection-local-set-profile-variables
+ 'remote-bash
+ (append
+ (connection-local-get-profile-variables 'remote-bash)
+ '((shell-command-dont-erase-buffer . t))))
+@end group
+@end example
@end defun
@deffn {User Option} connection-local-profile-alist
@@ -2418,6 +2433,37 @@ are unwound. Example:
@end example
@end defmac
+@defvar connection-local-default-application
+The default application, a symbol, to be applied in
+@code{with-connection-local-variables}. It defaults to @code{tramp},
+but in case you want to overwrite Tramp's settings temporarily, you
+could let-bind it like
+
+@example
+@group
+(connection-local-set-profile-variables
+ 'my-remote-perl
+ '((perl-command-name . "/usr/local/bin/perl5")
+ (perl-command-switch . "-e %s")))
+@end group
+
+@group
+(connection-local-set-profiles
+ '(:application 'my-app :protocol "ssh" :machine "remotehost")
+ 'my-remote-perl)
+@end group
+
+@group
+(let ((default-directory "/ssh:remotehost:/working/dir/")
+ (connection-local-default-application 'my-app))
+ (with-connection-local-variables
+ do something useful))
+@end group
+@end example
+
+This variable must not be changed globally.
+@end defvar
+
@defvar enable-connection-local-variables
If @code{nil}, connection-local variables are ignored. This variable
shall be changed temporarily only in special modes.
@@ -2743,13 +2789,13 @@ implemented this way:
(gv-define-expander substring
(lambda (do place from &optional to)
(gv-letplace (getter setter) place
- (macroexp-let2* nil ((start from) (end to))
- (funcall do `(substring ,getter ,start ,end)
+ (macroexp-let2* (from to)
+ (funcall do `(substring ,getter ,from ,to)
(lambda (v)
- (macroexp-let2 nil v v
+ (macroexp-let2* (v)
`(progn
,(funcall setter `(cl--set-substring
- ,getter ,start ,end ,v))
+ ,getter ,from ,to ,v))
,v))))))))
@end example
@end defmac
@@ -2762,7 +2808,7 @@ of Common Lisp could be implemented this way:
@example
(defmacro incf (place &optional n)
(gv-letplace (getter setter) place
- (macroexp-let2 nil v (or n 1)
+ (macroexp-let2* ((v (or n 1)))
(funcall setter `(+ ,v ,getter)))))
@end example
diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi
index 3b24dfb919c..71e3e6b9ed7 100644
--- a/doc/misc/eudc.texi
+++ b/doc/misc/eudc.texi
@@ -795,12 +795,73 @@ against the @code{cn} attribute of LDAP servers:
@end defvar
@defvar eudc-inline-expansion-format
-This variable lets you control exactly what is inserted into the buffer
-upon an inline expansion request. It is a list whose first element is a
-string passed to @code{format}. Remaining elements are symbols
-corresponding to directory attribute names. The corresponding attribute
-values are passed as additional arguments to @code{format}. Default is
-@code{("%s %s <%s>" firstname name email)}.
+This variable lets you control exactly what is inserted into the
+buffer upon an inline expansion request. It can be set to @code{nil},
+to a function, or to a list. Default is @code{nil}.
+
+When the value is a list, the first element is a string passed to
+@code{format}. Remaining elements are symbols corresponding to
+directory attribute names. The corresponding attribute values are
+passed as additional arguments to @code{format}.
+
+When the value is @code{nil}, the expansion result will be formatted
+according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC
+5322}. The @var{phrase} part will be formatted as ``firstname name'',
+quoting the result if necessary. No @var{comment} part will be added
+in this case. This will produce any of the default formats
+@center @var{address}
+@center @var{first} @code{<}@var{address}@code{>}
+@center @var{last} @code{<}@var{address}@code{>}
+@center @var{first} @var{last} @code{<}@var{address}@code{>}
+depending on whether a first and/or last name are returned by the
+query, or not.
+
+When the value is a function, the expansion result will be formatted
+according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC
+5322}, and the referenced function is called to format the
+@var{phrase}, and @var{comment} parts, respectively. The formatted
+@var{phrase} part will be quoted if necessary. Thus one can produce
+any of the formats:
+@center @var{address}
+@center @var{phrase} @code{<}@var{address}@code{>}
+@center @var{address} @code{(}@var{comment}@code{)}
+@center @var{phrase} @code{<}@var{address}@code{>} @code{(}@var{comment}@code{)}
+
+Email address specifications, as are generated by inline expansion,
+need to comply with RFC 5322 in order to be useful in email
+messages. When an invalid address specification is present in an email
+message header, the message is likely to be rejected by a receiving
+MTA. It is hence recommended to switch old configurations, which use
+a list value, to the new @code{nil}, or function value type since it
+ensures that the inserted address specifications will be in line with
+@url{https://datatracker.ietf.org/doc/html/rfc5322, RFC 5322}. At
+minimum, and to achieve the same semantics as with the old list
+default value, this variable should now be set to @code{nil}:
+@lisp
+(customize-set-variable 'eudc-inline-expansion-format nil)
+@end lisp
+
+A function value can for example be used to get @emph{``last, first
+<address>''} instead of the default @emph{``first last <address>''}:
+@lisp
+(defun my-phrase-last-comma-first (search-res-alist)
+ (let* (phrase
+ (my-attrs (eudc-translate-attribute-list '(firstname name)))
+ (first-name (cdr (assq (nth 0 my-attrs) search-res-alist)))
+ (last-name (cdr (assq (nth 1 my-attrs) search-res-alist)))
+ (comment nil))
+ (setq phrase (concat last-name ", " first-name))
+ (cons phrase comment)))
+
+(customize-set-variable 'eudc-inline-expansion-format
+ #'my-phrase-last-comma-first)
+@end lisp
+To set the @var{comment} part, too, instead of @code{nil} as in this
+example, also provide a string as the @code{cdr} of the @code{cons}
+being returned. Do not include any double quotes in the @var{phrase}
+part, as they are added automatically if needed. Neither include
+parentheses in the @var{comment} part as they, too, are added
+automatically.
@end defvar
@defvar eudc-multiple-match-handling-method
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index f87eab7e513..9faace1a75e 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -18078,6 +18078,17 @@ parameter of @code{nnselect-rescan} will allow automatic refreshing.
A refresh can always be invoked manually through
@code{gnus-group-get-new-news-this-group}.
+By default a compressed version of the selection is stored (for
+permanent groups) along with other group information in the newsrc.
+For cases where this might be undesirable (for example if the
+selection is a very long list that doesn't compress well) a
+non-@code{nil} group parameter of @code{nnselect-always-regenerate}
+will prevent the list from being stored, and instead regenerate the
+list each time it is needed. If more flexibility is desired,
+@code{nnselect-get-artlist-override-function} and
+@code{nnselect-store-artlist-override-function} may be set to
+functions that get and store the list of articles.
+
Gnus includes engines for searching a variety of backends. While the
details of each search engine vary, the result of a search is always a
vector of the sort used by the nnselect method, and the results of
@@ -21640,6 +21651,9 @@ are:
@item
@code{gnus-search-namazu}
+
+@item
+@code{gnus-search-mu}
@end itemize
If you need more granularity, you can specify a search engine in the
@@ -21654,7 +21668,7 @@ buffer. That might look like:
(config-file "/home/user/.mail/.notmuch_config")))
@end example
-Search engines like notmuch, namazu and mairix are similar in
+Search engines like notmuch, namazu, mairix and mu are similar in
behavior: they use a local executable to create an index of a message
store, and run command line search queries against those messages,
and return a list of absolute file names of matching messages.
@@ -21693,8 +21707,8 @@ The customization options are formed on the pattern
non-standard notmuch program, you might set
@code{gnus-search-notmuch-program} to @file{/usr/local/bin/notmuch}.
This would apply to all notmuch engines. The engines that use these
-options are: ``notmuch'', ``namazu'', ``mairix'', ``swish-e'' and
-``swish++''.
+options are: ``notmuch'', ``namazu'', ``mairix'', ``mu'', ``swish-e''
+and ``swish++''.
Alternately, the options can be set directly on your Gnus server
definitions, for instance, in the @code{nnmaildir} example above.
diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org
index 70f1e8bd1de..42ad3ee35fe 100644
--- a/doc/misc/modus-themes.org
+++ b/doc/misc/modus-themes.org
@@ -5,9 +5,9 @@
#+options: ':t toc:nil author:t email:t num:t
#+startup: content
-#+macro: stable-version 2.2.0
-#+macro: release-date 2022-02-23
-#+macro: development-version 2.3.0-dev
+#+macro: stable-version 2.3.0
+#+macro: release-date 2022-04-01
+#+macro: development-version 2.4.0-dev
#+macro: file @@texinfo:@file{@@$1@@texinfo:}@@
#+macro: space @@texinfo:@: @@
#+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@
@@ -15,7 +15,7 @@
#+texinfo_filename: modus-themes.info
#+texinfo_dir_category: Emacs misc features
#+texinfo_dir_title: Modus Themes: (modus-themes)
-#+texinfo_dir_desc: Highly accessible themes (WCAG AAA)
+#+texinfo_dir_desc: Elegant, highly legible and customizable themes
#+texinfo_header: @set MAINTAINERSITE @uref{https://protesilaos.com,maintainer webpage}
#+texinfo_header: @set MAINTAINER Protesilaos Stavrou
#+texinfo_header: @set MAINTAINEREMAIL @email{info@protesilaos.com}
@@ -222,16 +222,16 @@ They are now ready to be used: [[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable
#+cindex: Essential configuration
#+vindex: modus-themes-after-load-theme-hook
-Users of the built-in themes can load and automatically enable the theme
-of their preference by adding either form to their init file:
+Users of the built-in themes cannot ~require~ the package as usual
+because there is no package to speak of. Instead, things are simpler as
+all one needs is to load the theme of their preference by adding either
+form to their init file:
#+begin_src emacs-lisp
(load-theme 'modus-operandi) ; Light theme
(load-theme 'modus-vivendi) ; Dark theme
#+end_src
-This is all one needs.
-
Users of packaged variants of the themes must add a few more lines to
ensure that everything works as intended. First, one has to require the
main library before loading either theme:
@@ -260,24 +260,39 @@ a theme with either of the following expressions:
Changes to the available customization options must always be evaluated
before loading a theme ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). An exception to this
norm is when using the various Custom interfaces or with commands like
-{{{kbd(M-x customize-set-variable)}}}, which can automatically reload
-the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]). This is how a basic
-setup could look like:
+{{{kbd(M-x customize-set-variable)}}}, which can optionally
+automatically reload the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]).
+
+This is how a basic setup could look like:
#+begin_src emacs-lisp
+;;; For the built-in themes which cannot use `require':
+;; Add all your customizations prior to loading the themes
+(setq modus-themes-italic-constructs t
+ modus-themes-bold-constructs nil
+ modus-themes-region '(bg-only no-extend))
+
+;; Load the theme of your choice:
+(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi)
+
+(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
+
+
+
+;;; For packaged versions which must use `require':
(require 'modus-themes)
-;; Your customisations here. For example:
-(setq modus-themes-bold-constructs t
- modus-themes-mode-line '3d)
+;; Add all your customizations prior to loading the themes
+(setq modus-themes-italic-constructs t
+ modus-themes-bold-constructs nil
+ modus-themes-region '(bg-only no-extend))
-;; Load the theme files before enabling a theme (else you get an error).
+;; Load the theme files before enabling a theme
(modus-themes-load-themes)
-;; Enable the theme of your preference:
-(modus-themes-load-operandi)
+;; Load the theme of your choice:
+(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi)
-;; Optionally add a key binding for the toggle between the themes:
(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
#+end_src
@@ -307,15 +322,30 @@ It is common for Emacs users to rely on ~use-package~ for declaring
package configurations in their setup. We use this as an example:
#+begin_src emacs-lisp
+;;; For the built-in themes which cannot use `require':
+(use-package emacs
+ :init
+ ;; Add all your customizations prior to loading the themes
+ (setq modus-themes-italic-constructs t
+ modus-themes-bold-constructs nil
+ modus-themes-region '(bg-only no-extend))
+ :config
+ ;; Load the theme of your choice:
+ (load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi)
+ :bind ("<f5>" . modus-themes-toggle)
+
+
+
+;;; For packaged versions which must use `require':
(use-package modus-themes
- :ensure ; omit this to use the built-in themes
+ :ensure
:init
;; Add all your customizations prior to loading the themes
(setq modus-themes-italic-constructs t
modus-themes-bold-constructs nil
modus-themes-region '(bg-only no-extend))
- ;; Load the theme files before enabling a theme (else you get an error).
+ ;; Load the theme files before enabling a theme
(modus-themes-load-themes)
:config
;; Load the theme of your choice:
@@ -326,6 +356,20 @@ package configurations in their setup. We use this as an example:
The same without ~use-package~:
#+begin_src emacs-lisp
+;;; For the built-in themes which cannot use `require':
+;; Add all your customizations prior to loading the themes
+(setq modus-themes-italic-constructs t
+ modus-themes-bold-constructs nil
+ modus-themes-region '(bg-only no-extend))
+
+;; Load the theme of your choice:
+(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi)
+
+(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
+
+
+
+;;; For packaged versions which must use `require':
(require 'modus-themes)
;; Add all your customizations prior to loading the themes
@@ -418,6 +462,7 @@ this manual.
modus-themes-bold-constructs nil
modus-themes-mixed-fonts nil
modus-themes-subtle-line-numbers nil
+ modus-themes-intense-mouseovers nil
modus-themes-deuteranopia t
modus-themes-tabs-accented t
modus-themes-variable-pitch-ui nil
@@ -433,8 +478,14 @@ this manual.
;; Options for `modus-themes-mode-line' are either nil, or a list
;; that can combine any of `3d' OR `moody', `borderless',
- ;; `accented', and a natural number for extra padding
- modus-themes-mode-line '(4 accented borderless)
+ ;; `accented', a natural number for extra padding (or a cons cell
+ ;; of padding and NATNUM), and a floating point for the height of
+ ;; the text relative to the base font size (or a cons cell of
+ ;; height and FLOAT)
+ modus-themes-mode-line '(accented borderless (padding . 4) (height . 0.9))
+
+ ;; Same as above:
+ ;; modus-themes-mode-line '(accented borderless 4 0.9)
;; Options for `modus-themes-markup' are either nil, or a list
;; that can combine any of `bold', `italic', `background',
@@ -464,9 +515,10 @@ this manual.
;; Options for `modus-themes-box-buttons' are either nil (the
;; default), or a list that can combine any of `flat', `accented',
- ;; `faint', `variable-pitch', `underline', the symbol of any font
- ;; weight as listed in `modus-themes-weights', and a floating
- ;; point number (e.g. 0.9) for the height of the button's text.
+ ;; `faint', `variable-pitch', `underline', `all-buttons', the
+ ;; symbol of any font weight as listed in `modus-themes-weights',
+ ;; and a floating point number (e.g. 0.9) for the height of the
+ ;; button's text.
modus-themes-box-buttons '(variable-pitch flat faint 0.9)
;; Options for `modus-themes-prompts' are either nil (the
@@ -479,8 +531,8 @@ this manual.
;; value (or empty list) or a list of properties that can include
;; any of the following (for WEIGHT read further below):
;;
- ;; `key' - `background', `intense', `underline', `italic', WEIGHT
- ;; `selection' - `accented', `intense', `underline', `italic', WEIGHT
+ ;; `matches' - `background', `intense', `underline', `italic', WEIGHT
+ ;; `selection' - `accented', `intense', `underline', `italic', `text-also' WEIGHT
;; `popup' - same as `selected'
;; `t' - applies to any key not explicitly referenced (check docs)
;;
@@ -841,7 +893,9 @@ an empty list). The list can include any of the following symbols:
- ~heavy~
- ~extrabold~
- ~ultrabold~
-+ A floating point as a height multiple of the default (e.g. =0.9=)
++ A floating point as a height multiple of the default or a cons cell in
+ the form of =(height . FLOAT)=
++ ~all-buttons~
The default (a nil value or an empty list) is a gray background combined
with a pseudo three-dimensional effect.
@@ -873,6 +927,14 @@ defined in the variable ~modus-themes-weights~.
A number, expressed as a floating point (e.g. =0.9=), adjusts the height
of the button's text to that many times the base font size. The default
height is the same as =1.0=, though it need not be explicitly stated.
+Instead of a floating point, an acceptable value can be in the form of a
+cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is
+the given number.
+
+The ~all-buttons~ property extends the box button effect (or the
+aforementioned properties) to the faces of the generic widget library.
+By default, those do not look like the buttons of the Custom UI as they
+are ordinary text wrapped in square brackets.
Combinations of any of those properties are expressed as a list,
like in these examples:
@@ -880,7 +942,9 @@ like in these examples:
#+begin_src emacs-lisp
(flat)
(variable-pitch flat)
-(variable-pitch flat 0.9 semibold)
+(variable-pitch flat semibold 0.9)
+(variable-pitch flat semibold (height 0.9)) ; same as above
+(variable-pitch flat semibold (height . 0.9)) ; same as above
#+end_src
The order in which the properties are set is not significant.
@@ -970,7 +1034,10 @@ effect, color, and border visibility:
- ~moody~
+ ~accented~
+ ~borderless~
-+ A natural number > 1 for extra padding
++ A natural number > 1 for extra padding or a cons cell in the form of
+ ~(padding . NATNUM)~.
++ A floating point to set the height of the mode line's text. It can
+ also be a cons cell in the form of ~(height . FLOAT)~.
The default (a nil value or an empty list) is a two-dimensional
rectangle with a border around it. The active and the inactive mode
@@ -1006,6 +1073,17 @@ bottom of the mode line, set ~x-underline-at-descent-line~ to non-nil
users on Emacs 29, the ~x-use-underline-position-properties~ variable must
also be set to nil.
+The padding can also be expressed as a cons cell in the form of
+=(padding . NATNUM)= or =(padding NATNUM)= where the key is constant and
+NATNUM is the desired natural number.
+
+A floating point applies an adjusted height to the mode line's text as a
+multiple of the main font size. The default rate is 1.0 and does not
+need to be specified. Apart from a floating point, the height may also
+be expressed as a cons cell in the form of =(height . FLOAT)= or
+=(height FLOAT)= where the key is constant and the FLOAT is the desired
+number.
+
Combinations of any of those properties are expressed as a list, like in
these examples:
@@ -1015,6 +1093,15 @@ these examples:
(moody accented borderless)
#+end_src
+Same as above, using the padding and height as an example (these
+all yield the same result):
+
+#+begin_src emacs-lisp
+(accented borderless 4 0.9)
+(accented borderless (padding . 4) (height . 0.9))
+(accented borderless (padding 4) (height 0.9))
+#+end_src
+
The order in which the properties are set is not significant.
In user configuration files the form may look like this:
@@ -1117,12 +1204,14 @@ appear in:
The ~selection~ key applies to the current line or currently matched
candidate, depending on the specifics of the User Interface. By default
-(nil or an empty list), it has a subtle gray background and a bold
-weight. The list of properties it accepts is as follows (order is not
-significant):
+(nil or an empty list), it has a subtle gray background, a bold weight,
+and the base foreground value for the text. The list of properties it
+accepts is as follows (order is not significant):
- ~accented~ to make the background colorful instead of gray;
+- ~text-also~ to apply extra color to the text of the selected line;
+
- ~intense~ to increase the overall coloration;
- ~underline~ to draw a line below the characters;
@@ -1154,8 +1243,9 @@ Is the same as:
#+end_src
In the case of the fallback, any property that does not apply to the
-corresponding key is simply ignored (~matches~ does not have ~accented~,
-~selection~ and ~popup~ do not have ~background~).
+corresponding key is simply ignored (~matches~ does not have ~accented~
+and ~text-also~, while ~selection~ and ~popup~ do not have
+~background~).
A concise expression of those associations can be written as follows,
where the ~car~ is always the key and the ~cdr~ is the list of
@@ -1389,6 +1479,29 @@ Instead they retain the primary background of the theme, blending with
the rest of the buffer. Foreground values for all relevant faces are
updated to accommodate this aesthetic.
+** Option for mouseover effects
+:properties:
+:alt_title: Mouse hover effects
+:description: Toggle intense style for mouseover highlights
+:custom_id: h:9b869620-fcc5-4b5f-9ab8-225d73b7f22f
+:end:
+#+vindex: modus-themes-intense-mouseovers
+
+Brief: Toggle intense mouse hover effects.
+
+Symbol: ~modus-themes-intense-mouseovers~ (=boolean= type)
+
+Possible value:
+
+1. ~nil~ (default)
+2. ~t~
+
+By default all mouseover effects apply a highlight with a subtle colored
+background. When non-nil, these have a more pronounced effect.
+
+Note that this affects the generic ~highlight~ which, strictly speaking,
+is not limited to mouse usage.
+
** Option for markup style in Org and others
:properties:
:alt_title: Markup
@@ -1674,12 +1787,18 @@ come in the form of a list that can include either or both of those
properties:
- ~variable-pitch~ to use a proportionately spaced typeface;
+
- A number as a floating point (e.g. 1.5) to set the height of the text
to that many times the default font height. A float of 1.0 or the
- symbol ~no-scale~ have the same effect of making the font to the same
- height as the rest of the buffer. When neither a number nor ~no-scale~
- are present, the default is a small increase in height (a value of
- 1.15).
+ symbol ~no-scale~ have the same effect of making the font the same
+ height as the rest of the buffer. When neither a number nor
+ `no-scale' are present, the default is a small increase in height (a
+ value of 1.15).
+
+ Instead of a floating point, an acceptable value can be in the form of
+ a cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT
+ is the given number.
+
- The symbol of a weight attribute adjusts the font of the heading
accordingly, such as ~light~, ~semibold~, etc. Valid symbols are
defined in the variable ~modus-themes-weights~. The absence of a
@@ -1709,16 +1828,24 @@ the following properties:
- ~grayscale~ to make weekdays use the main foreground color and
weekends a more subtle gray;
+
- ~workaholic~ to make weekdays and weekends look the same in
terms of color;
+
- ~bold-today~ to apply a bold typographic weight to the current
date;
+
- ~bold-all~ to render all date headings in a bold weight;
+
- ~underline-today~ applies an underline to the current date while
removing the background it has by default;
+
- A number as a floating point (e.g. 1.2) to set the height of the text
to that many times the default font height. The default is the same
- as the base font height (the equivalent of 1.0).
+ as the base font height (the equivalent of 1.0). Instead of a
+ floating point, an acceptable value can be in the form of a cons cell
+ like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is the given
+ number.
For example:
@@ -1805,7 +1932,7 @@ passed as a symbol. Those are:
attenuated by painting both of them using shades of green. This
option thus highlights the alert and overdue states.
- When ~modus-themes-deuteranopia~ is non-nil the exact style of the habit
- graph adapts to the needs of users with red-green colour deficiency by
+ graph adapts to the needs of users with red-green color deficiency by
substituting every instance of green with blue or cyan (depending on
the specifics).
@@ -1884,7 +2011,8 @@ Properties:
- ~extrabold~
- ~ultrabold~
+ ~no-bold~ (deprecated alias of a ~regular~ weight)
-+ A floating point as a height multiple of the default (e.g. =1.1=)
++ A floating point as a height multiple of the default or a cons cell in
+ the form of =(height . FLOAT)=.
By default (a ~nil~ value for this variable), all headings have a bold
typographic weight and use a desaturated text color.
@@ -1916,6 +2044,9 @@ users are encouraged to specify a ~regular~ weight instead.
A number, expressed as a floating point (e.g. 1.5), adjusts the height
of the heading to that many times the base font size. The default
height is the same as 1.0, though it need not be explicitly stated.
+Instead of a floating point, an acceptable value can be in the form of a
+cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is
+the given number.
Combinations of any of those properties are expressed as a list, like in
these examples:
@@ -1924,6 +2055,8 @@ these examples:
(semibold)
(rainbow background)
(overline monochrome semibold 1.3)
+(overline monochrome semibold (height 1.3)) ; same as above
+(overline monochrome semibold (height . 1.3)) ; same as above
#+end_src
The order in which the properties are set is not significant.
@@ -2032,6 +2165,77 @@ Another example that can be bound to a key:
: TERM=xterm-direct uxterm -e emacsclient -nw
+** Range of color with terminal emulators
+:PROPERTIES:
+:CUSTOM_ID: h:6b8211b0-d11b-4c00-9543-4685ec3b742f
+:END:
+#+cindex: Pure white and pure black in terminal emulators
+
+[ This is based on partial information. Please help verify and/or
+ expand these findings. ]
+
+When Emacs runs in a non-windowed session its color reproduction
+capacity is framed or determined by the underlying terminal emulator
+([[#h:fbb5e254-afd6-4313-bb05-93b3b4f67358][More accurate colors in terminal emulators]]). Emacs cannot produce a
+color that lies outside the range of what the terminal's color palette
+renders possible.
+
+This is immediately noticeable when the terminal's first 16 codes do not
+include a pure black value for the =termcol0= entry and a pure white for
+=termcol15=. Emacs cannot set the correct background (white for
+~modus-operandi~; black for ~modus-vivendi~) or foreground (inverse of
+the background). It thus falls back to the closest approximation, which
+seldom is appropriate for the purposes of the Modus themes.
+
+In such a case, the user is expected to update their terminal's color
+palette such as by adapting these resources:
+
+#+begin_src emacs-lisp
+! Theme: modus-operandi
+! Description: XTerm port of modus-operandi (Modus themes for GNU Emacs)
+! Author: Protesilaos Stavrou, <https://protesilaos.com>
+xterm*background: #ffffff
+xterm*foreground: #000000
+xterm*color0: #000000
+xterm*color1: #a60000
+xterm*color2: #005e00
+xterm*color3: #813e00
+xterm*color4: #0031a9
+xterm*color5: #721045
+xterm*color6: #00538b
+xterm*color7: #bfbfbf
+xterm*color8: #595959
+xterm*color9: #972500
+xterm*color10: #315b00
+xterm*color11: #70480f
+xterm*color12: #2544bb
+xterm*color13: #5317ac
+xterm*color14: #005a5f
+xterm*color15: #ffffff
+
+! Theme: modus-vivendi
+! Description: XTerm port of modus-vivendi (Modus themes for GNU Emacs)
+! Author: Protesilaos Stavrou, <https://protesilaos.com>
+xterm*background: #000000
+xterm*foreground: #ffffff
+xterm*color0: #000000
+xterm*color1: #ff8059
+xterm*color2: #44bc44
+xterm*color3: #d0bc00
+xterm*color4: #2fafff
+xterm*color5: #feacd0
+xterm*color6: #00d3d0
+xterm*color7: #bfbfbf
+xterm*color8: #595959
+xterm*color9: #ef8b50
+xterm*color10: #70b900
+xterm*color11: #c0c530
+xterm*color12: #79a8ff
+xterm*color13: #b6a0ff
+xterm*color14: #6ae4b9
+xterm*color15: #ffffff
+#+end_src
+
** Visualize the active Modus theme's palette
:properties:
:custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d
@@ -2553,7 +2757,7 @@ The themes provide a mechanism for overriding their color values. This
is controlled by the variables ~modus-themes-operandi-color-overrides~ and
~modus-themes-vivendi-color-overrides~, which are alists that should
mirror a subset of the associations in ~modus-themes-operandi-colors~ and
-~modus-themes-vivendi-colors~ respectively. As with all customisations,
+~modus-themes-vivendi-colors~ respectively. As with all customizations,
overriding must be done before loading the affected theme.
[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]].
@@ -2659,7 +2863,7 @@ Operandi and night sky blue shades for Modus Vivendi. Switching between
the two themes, such as with {{{kbd(M-x modus-themes-toggle)}}} will
also use the overrides.
-Given that this is a user-level customisation, one is free to implement
+Given that this is a user-level customization, one is free to implement
whatever color values they desire, even if the possible combinations
fall below the minimum 7:1 contrast ratio that governs the design of the
themes (the WCAG AAA legibility standard). Alternatively, this can also
@@ -3720,6 +3924,135 @@ coloration.
[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]].
+** Near-monochrome syntax highlighting
+:properties:
+:custom_id: h:c1f3fa8e-7a63-4a6f-baf3-a7febc0661f0
+:end:
+#+cindex: Monochrome code syntax
+
+While the Modus themes do provide a user option to control the overall
+style of syntax highlighting in programming major modes, they do not
+cover the possibility of a monochromatic or near-monochromatic design
+([[#h:c119d7b2-fcd4-4e44-890e-5e25733d5e52][Option for syntax highlighting]]). This is due to the multitude of
+preferences involved: one may like comments to be styled with an accent
+value, another may want certain constructs to be bold, a third may apply
+italics to doc strings but not comments... The possibilities are
+virtually endless. As such, this sort of design is best handled at the
+user level in accordance with the information furnished elsewhere in
+this manual.
+
+[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Case-by-case face specs using the themes' palette]].
+
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+
+The gist is that we want to override the font-lock faces. For our
+changes to persist while switching between ~modus-operandi~ and
+~modus-vivendi~ we wrap our face overrides in a function that we hook to
+~modus-themes-after-load-theme-hook~.
+
+Users who want to replicate the structure of the themes' source code are
+advised to use the examples with ~custom-set-faces~. Those who prefer a
+different approach can use the snippets which call ~set-face-attribute~.
+Below are the code blocks.
+
+The following uses a yellow accent value for comments and green hues for
+strings. Regexp grouping constructs have color values that work in the
+context of a green string. All other elements use the main foreground
+color, except warnings such as the ~user-error~ function in Elisp
+buffers which gets a subtle red tint (not to be confused with the
+~warning~ face which is used for genuine warnings). Furthermore, notice
+the ~modus-themes-bold~ and ~modus-themes-slant~ which apply the
+preference set in the user options ~modus-themes-bold-constructs~ and
+~modus-themes-italic-constructs~, respectively. Users who do not want
+this conditionally must replace these faces with ~bold~ and ~italic~
+respectively (or ~unspecified~ to disable the effect altogether).
+
+#+begin_src emacs-lisp
+;; This is the hook. It will not be replicated across all code samples.
+(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-subtle-syntax)
+
+(defun my-modus-themes-subtle-syntax ()
+ (modus-themes-with-colors
+ (custom-set-faces
+ `(font-lock-builtin-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face)))
+ `(font-lock-comment-face ((,class :inherit unspecified :foreground ,fg-comment-yellow)))
+ `(font-lock-constant-face ((,class :foreground unspecified)))
+ `(font-lock-doc-face ((,class :inherit modus-themes-slant :foreground ,fg-special-mild)))
+ `(font-lock-function-name-face ((,class :foreground unspecified)))
+ `(font-lock-keyword-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-negation-char-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-preprocessor-face ((,class :foreground unspecified)))
+ `(font-lock-regexp-grouping-backslash ((,class :inherit bold :foreground ,yellow)))
+ `(font-lock-regexp-grouping-construct ((,class :inherit bold :foreground ,blue-alt-other)))
+ `(font-lock-string-face ((,class :foreground ,green-alt-other)))
+ `(font-lock-type-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-variable-name-face ((,class :foreground unspecified)))
+ `(font-lock-warning-face ((,class :inherit modus-themes-bold :foreground ,red-nuanced-fg))))))
+
+;; Same as above with `set-face-attribute' instead of `custom-set-faces'
+(defun my-modus-themes-subtle-syntax ()
+ (modus-themes-with-colors
+ (set-face-attribute 'font-lock-builtin-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-comment-delimiter-face nil :inherit 'font-lock-comment-face)
+ (set-face-attribute 'font-lock-comment-face nil :inherit 'unspecified :foreground fg-comment-yellow)
+ (set-face-attribute 'font-lock-constant-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-doc-face nil :inherit 'modus-themes-slant :foreground fg-special-mild)
+ (set-face-attribute 'font-lock-function-name-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-keyword-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-negation-char-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-preprocessor-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-regexp-grouping-backslash nil :inherit 'bold :foreground yellow)
+ (set-face-attribute 'font-lock-regexp-grouping-construct nil :inherit 'bold :foreground blue-alt-other)
+ (set-face-attribute 'font-lock-string-face nil :foreground green-alt-other)
+ (set-face-attribute 'font-lock-type-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-variable-name-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-warning-face nil :inherit 'modus-themes-bold :foreground red-nuanced-fg)))
+#+end_src
+
+The following sample is the same as above, except strings are blue and
+comments are gray. Regexp constructs are adapted accordingly.
+
+#+begin_src emacs-lisp
+(defun my-modus-themes-subtle-syntax ()
+ (modus-themes-with-colors
+ (custom-set-faces
+ `(font-lock-builtin-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face)))
+ `(font-lock-comment-face ((,class :inherit unspecified :foreground ,fg-alt)))
+ `(font-lock-constant-face ((,class :foreground unspecified)))
+ `(font-lock-doc-face ((,class :inherit modus-themes-slant :foreground ,fg-docstring)))
+ `(font-lock-function-name-face ((,class :foreground unspecified)))
+ `(font-lock-keyword-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-negation-char-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-preprocessor-face ((,class :foreground unspecified)))
+ `(font-lock-regexp-grouping-backslash ((,class :inherit bold :foreground ,fg-escape-char-backslash)))
+ `(font-lock-regexp-grouping-construct ((,class :inherit bold :foreground ,fg-escape-char-construct)))
+ `(font-lock-string-face ((,class :foreground ,blue-alt)))
+ `(font-lock-type-face ((,class :inherit modus-themes-bold :foreground unspecified)))
+ `(font-lock-variable-name-face ((,class :foreground unspecified)))
+ `(font-lock-warning-face ((,class :inherit modus-themes-bold :foreground ,red-nuanced-fg))))))
+
+;; Same as above with `set-face-attribute' instead of `custom-set-faces'
+(defun my-modus-themes-subtle-syntax ()
+ (modus-themes-with-colors
+ (set-face-attribute 'font-lock-builtin-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-comment-delimiter-face nil :inherit 'font-lock-comment-face)
+ (set-face-attribute 'font-lock-comment-face nil :inherit 'unspecified :foreground fg-alt)
+ (set-face-attribute 'font-lock-constant-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-doc-face nil :inherit 'modus-themes-slant :foreground fg-docstring)
+ (set-face-attribute 'font-lock-function-name-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-keyword-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-negation-char-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-preprocessor-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-regexp-grouping-backslash nil :inherit 'bold :foreground fg-escape-char-backslash)
+ (set-face-attribute 'font-lock-regexp-grouping-construct nil :inherit 'bold :foreground fg-escape-char-construct)
+ (set-face-attribute 'font-lock-string-face nil :foreground blue-alt)
+ (set-face-attribute 'font-lock-type-face nil :inherit 'modus-themes-bold :foreground 'unspecified)
+ (set-face-attribute 'font-lock-variable-name-face nil :foreground 'unspecified)
+ (set-face-attribute 'font-lock-warning-face nil :inherit 'modus-themes-bold :foreground red-nuanced-fg)))
+#+end_src
+
* Face coverage
:properties:
:custom_id: h:a9c8f29d-7f72-4b54-b74b-ddefe15d6a19
@@ -3793,6 +4126,7 @@ have lots of extensions, so the "full support" may not be 100% true…
+ deadgrep
+ debbugs
+ deft
++ devdocs
+ dictionary
+ diff-hl
+ diff-mode
@@ -3914,6 +4248,7 @@ have lots of extensions, so the "full support" may not be 100% true…
+ mct
+ mentor
+ messages
++ mini-modeline
+ minimap
+ mmm-mode
+ mode-line
@@ -4063,6 +4398,7 @@ supported by the themes.
+ dtache
+ easy-kill
+ edit-indirect
++ elfeed-summary
+ evil-owl
+ flyspell-correct
+ fortran-mode
@@ -4083,6 +4419,7 @@ supported by the themes.
+ swift-mode
+ tab-bar-echo-area
+ tide
++ undo-hl
+ vdiff
+ vertico-indexed
+ vertico-mouse
@@ -4239,29 +4576,20 @@ package: it draws too much attention to unfocused windows.
:custom_id: h:2a602816-bc1b-45bf-9675-4cbbd7bf6cab
:end:
-While designing the style for ~display-fill-column-indicator-mode~, we
-stayed close to the mode's defaults: to apply a subtle foreground color
-to the ~fill-column-indicator~ face, which blends well with the rest of
-theme and is consistent with the role of that mode. This is to not
-upset the expectations of users.
-
-Nevertheless, ~display-fill-column-indicator-mode~ has some known
-limitations pertaining to its choice of using typographic characters to
-draw its indicator. What should be a continuous vertical line might
-appear as a series of dashes in certain contexts or under specific
-conditions: a non-default value for ~line-spacing~, scaled and/or
-variable-pitch headings have been observed to cause this effect.
+The ~display-fill-column-indicator-mode~ uses a typographic character to
+draw its line. This has the downside of creating a dashed line. The
+dashes are further apart depending on how tall the font's glyph height
+is and what integer the ~line-spacing~ is set to.
-Given that we cannot control such factors, it may be better for affected
-users to deviate from the default style of the ~fill-column-indicator~
-face. Instead of setting a foreground color, one could use a background
-and have the foreground be indistinguishable from it. For example:
+At the theme level we eliminate this effect by making the character one
+pixel tall: the line is contiguous. Users who prefer the dashed line
+are advised to change the ~fill-column-indicator~ face, as explained
+elsewhere in this document. For example:
#+begin_src emacs-lisp
(modus-themes-with-colors
(custom-set-faces
- `(fill-column-indicator ((,class :background ,bg-inactive
- :foreground ,bg-inactive)))))
+ `(fill-column-indicator ((,class :foreground ,bg-active)))))
#+end_src
[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
@@ -4456,7 +4784,7 @@ implements an alternative to the typical coloration of code. Instead of
highlighting the syntactic constructs, it applies color to different
levels of depth in the code structure.
-As {{{file(prism.el)}}} offers a broad range of customisations, we cannot
+As {{{file(prism.el)}}} offers a broad range of customizations, we cannot
style it directly at the theme level: that would run contrary to the
spirit of the package. Instead, we may offer preset color schemes.
Those should offer a starting point for users to adapt to their needs.
@@ -4644,7 +4972,7 @@ Emacs' HTML rendering library ({{{file(shr.el)}}}) may need explicit
configuration to respect the theme's colors instead of whatever
specifications the webpage provides.
-Consult {{{kbd(C-h v shr-use-colors)}}}.
+Consult the doc string of ~shr-use-colors~.
** Note on SHR fonts
:properties:
@@ -4806,6 +5134,20 @@ you've customized any faces.
"-draw" "text %X,%Y '%c'"))))
#+end_src
+** Note on the Notmuch logo
+:properties:
+:custom_id: h:636af312-54a5-4918-84a6-0698e85a3c6d
+:end:
+
+By default, the "hello" buffer of Notmuch includes a header with the
+programs' logo and a couple of buttons. The logo has the effect of
+enlarging the height of the line, which negatively impacts the shape of
+those buttons. Disabling the logo fixes the problem:
+
+#+begin_src emacs-lisp
+(setq notmuch-show-logo nil)
+#+end_src
+
* Frequently Asked Questions
:properties:
:custom_id: h:b3384767-30d3-4484-ba7f-081729f03a47
@@ -5124,8 +5466,8 @@ themes remains consistent.
The former criterion should be crystal clear as it pertains to the
scientific foundations of the themes: high legibility and taking care of
-the needs of users with red-green colour deficiency (deuteranopia) by
-avoiding red+green colour coding paradigms and/or by providing red+blue
+the needs of users with red-green color deficiency (deuteranopia) by
+avoiding red+green color coding paradigms and/or by providing red+blue
variants.
The latter criterion is the "je ne sais quoi" of the artistic aspect of
@@ -5143,7 +5485,7 @@ but try to understand its spirit.
For a trivial example: the curly underline that Emacs draws for spelling
errors is thinner than, e.g., what a graphical web browser has, so if I
was to design for an editor than has a thicker curly underline I would
-make the applicable colours less intense to counterbalance the
+make the applicable colors less intense to counterbalance the
typographic intensity of the added thickness.
With those granted, if anyone is willing to develop a port of the
@@ -5166,8 +5508,8 @@ in which you can contribute to their ongoing development.
The ~modus-operandi~ and ~modus-vivendi~ themes are built into Emacs 28.
-The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/][available on Gitlab]], for the time
-being. A [[https://github.com/protesilaos/modus-themes/][mirror on Github]] is also on offer.
+The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/][available on GitLab]], for the time
+being. A [[https://github.com/protesilaos/modus-themes/][mirror on GitHub]] is also on offer.
An HTML version of this manual is provided as an extension of the
[[https://protesilaos.com/emacs/modus-themes/][author's personal website]] (does not rely on any non-free code).
@@ -5274,37 +5616,39 @@ The Modus themes are a collective effort. Every bit of work matters.
+ Author/maintainer :: Protesilaos Stavrou.
+ Contributions to code or documentation :: Alex Griffin, Anders
- Johansson, Basil L.{{{space()}}} Contovounesios, Björn Lindström, Carlo
- Zancanaro, Christian Tietze, Daniel Mendler, Eli Zaretskii, Fritz
- Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev, Madhavan
- Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, Nicolas De
- Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas
- Ragavan, Stefan Kangas, Utkarsh Singh, Vincent Murphy, Xinglu Chen,
- Yuanchen Xie.
+ Johansson, Basil L.{{{space()}}} Contovounesios, Björn Lindström,
+ Carlo Zancanaro, Christian Tietze, Daniel Mendler, Eli Zaretskii,
+ Fritz Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev,
+ Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda,
+ Nicolas De Jaeghere, Philip Kaludercic, Pierre Téchoueyres, Rudolf
+ Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan Kangas, Utkarsh
+ Singh, Vincent Murphy, Xinglu Chen, Yuanchen Xie.
+ Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers,
Adrian Manea, Alex Griffin, Alex Koen, Alex Peitsinis, Alexey Shmalko,
- Alok Singh, Anders Johansson, André Alexandre Gomes, Arif Rezai, Basil
- L.{{{space()}}} Contovounesios, Burgess Chang, Christian Tietze,
- Christopher Dimech, Damien Cassou, Daniel Mendler, Dario Gjorgjevski,
- David Edmondson, Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele
- Michele Alberto Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet,
- Gerry Agbobada, Gianluca Recchia, Guilherme Semente, Gustavo Barros,
- Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry
- Zhang, Johannes Grødem, John Haman, Joshua O'Connor, Kenta Usami,
- Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg, Magne Hov,
- Manuel Uberti, Mark Bestley, Mark Burton, Markus Beppler, Mauro
- Aranda, Michael Goldenberg, Morgan Smith, Murilo Pereira, Nicky van
+ Alok Singh, Anders Johansson, André Alexandre Gomes, Antonio Hernández
+ Blas, Arif Rezai, Augusto Stoffel, Basil L.{{{space()}}}
+ Contovounesios, Burgess Chang, Christian Tietze, Christopher Dimech,
+ Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David Edmondson,
+ Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele Michele Alberto
+ Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, Gerry Agbobada,
+ Gianluca Recchia, Guilherme Semente, Gustavo Barros, Hörmetjan Yiltiz,
+ Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry Zhang, Johannes
+ Grødem, John Haman, Jorge Morais, Joshua O'Connor, Julio
+ C. Villasante, Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kostadin
+ Ninev, Len Trigg, Lennart C. Karssen, Magne Hov, Manuel Uberti, Mark
+ Bestley, Mark Burton, Markus Beppler, Mauro Aranda, Michael
+ Goldenberg, Morgan Smith, Morgan Willcock, Murilo Pereira, Nicky van
Foreest, Nicolas De Jaeghere, Paul Poloskov, Pengji Zhang, Pete
- Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Roman
- Rudakov, Ryan Phillips, Rudolf Adamkovič, Sam Kleinman, Samuel
- Culpepper, Saša Janiška, Shreyas Ragavan, Simon Pugnet, Tassilo Horn,
- Thibaut Verron, Thomas Heartman, Togan Muftuoglu, Trey Merkley, Tomasz
- Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As
- well as users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux,
- Fredrik, Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream,
- derek-upham, doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn,
- pRot0ta1p.
+ Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Robert
+ Hepple, Roman Rudakov, Ryan Phillips, Rytis Paškauskas, Rudolf
+ Adamkovič, Sam Kleinman, Samuel Culpepper, Saša Janiška, Shreyas
+ Ragavan, Simon Pugnet, Tassilo Horn, Thibaut Verron, Thomas Heartman,
+ Togan Muftuoglu, Tony Zorman, Trey Merkley, Tomasz Hołubowicz, Toon
+ Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As well as users:
+ Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik,
+ Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream, derek-upham,
+ doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, pRot0ta1p.
+ Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn
Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs),
diff --git a/doc/misc/ses.texi b/doc/misc/ses.texi
index 0acb7bf3f15..6d0415cdbbb 100644
--- a/doc/misc/ses.texi
+++ b/doc/misc/ses.texi
@@ -220,7 +220,14 @@ You move around with the regular Emacs movement commands.
@table @kbd
@item j
-Moves point to cell, specified by identifier (@code{ses-jump}).
+Moves point to cell, specified by identifier (@code{ses-jump}). Unless
+the cell is a renamed cell, the identifier is case-insensitive. A
+prefix argument @math{n} move to cell with coordinates @math{(n\div R,
+n \% C)} for a spreadsheet of @math{R} rows and @math{C} columns, and
+A1 being of coordinates @math{(0,0)}. The way the identifier or the
+command prefix argument are interpreted can be customized through
+variables @code{ses-jump-cell-name-function} and
+@code{ses-jump-prefix-function}.
@end table
Point is always at the left edge of a cell, or at the empty endline.
@@ -726,10 +733,6 @@ yank. This doesn't make any difference?
@section Customizing @acronym{SES}
@cindex customizing
@vindex enable-local-eval
-@vindex ses-mode-hook
-@vindex safe-functions
-@vindex enable-local-eval
-
By default, a newly-created spreadsheet has 1 row and 1 column. The
column width is 7 and the default printer is @samp{"%.7g"}. Each of these
@@ -740,9 +743,34 @@ cell. You can customize @code{ses-after-entry-functions} to move left or
up or down. For diagonal movement, select two functions from the
list.
+@vindex ses-jump-cell-name-function
+@code{ses-jump-cell-name-function} is a customizable variable by
+default set to the @code{upcase} function. This function is called
+when you pass a cell name to the @command{ses-jump} command (@kbd{j}),
+it changes the entered cell name to that where to jump. The default
+setting @code{upcase} allows you to enter the cell name in low
+case. Another use of @code{ses-jump-cell-name-function} could be some
+internationalisation to convert non latin characters into latin
+equivalents to name the cell. Instead of a cell name, the function may
+return cell coordinates in the form of a cons, for instance @code{(0
+. 0)} for cell @code{A1}, @code{(1 . 0)} for cell @code{A2}, etc.
+
+@vindex ses-jump-prefix-function
+@code{ses-jump-prefix-function} is a customisable variable by default
+set to the @code{ses-jump-prefix} function. This function is called
+when you give a prefix argument to the @command{ses-jump} command
+(@kbd{j}). It returns a cell name or cell coordinates corresponding to
+the prefix argument. Cell coordinates are in the form of a cons, for
+instance @code{(1 . 0)} for cell @code{A2}. The default setting
+@code{ses-jump-prefix} will number cells left to right and then top
+down, so assuming a 4x3 spreadsheet prefix argument 0 jumps to cell
+A1, prefix argument 2 jumps to C1, prefix argument 3 jumps to A2, etc.
+
+@vindex ses-mode-hook
@code{ses-mode-hook} is a normal mode hook (list of functions to
execute when starting @acronym{SES} mode for a buffer).
+@vindex safe-functions
The variable @code{safe-functions} is a list of possibly-unsafe
functions to be treated as safe when analyzing formulas and printers.
@xref{Virus protection}. Before customizing @code{safe-functions},
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 62bcf9c73b3..3cc312d2f5e 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -1881,29 +1881,25 @@ Example:
The following predefined functions parsing configuration files exist:
-@table @asis
+@ftable @asis
@item @code{tramp-parse-rhosts}
-@findex tramp-parse-rhosts
This function parses files which are syntactical equivalent to
@file{~/.rhosts}. It returns both host names and user names, if
specified.
@item @code{tramp-parse-shosts}
-@findex tramp-parse-shosts
This function parses files which are syntactical equivalent to
@file{~/.ssh/known_hosts}. Since there are no user names specified
in such files, it can return host names only.
@item @code{tramp-parse-sconfig}
-@findex tramp-parse-sconfig
This function returns the host nicknames defined by @option{Host}
entries in @file{~/.ssh/config} style files.
@item @code{tramp-parse-shostkeys}
-@findex tramp-parse-shostkeys
SSH2 parsing of directories @file{/etc/ssh2/hostkeys/*} and
@file{~/ssh2/hostkeys/*}. Hosts are coded in file names
@@ -1911,7 +1907,6 @@ SSH2 parsing of directories @file{/etc/ssh2/hostkeys/*} and
are always @code{nil}.
@item @code{tramp-parse-sknownhosts}
-@findex tramp-parse-sknownhosts
Another SSH2 style parsing of directories like
@file{/etc/ssh2/knownhosts/*} and @file{~/ssh2/knownhosts/*}. This
@@ -1919,26 +1914,22 @@ case, hosts names are coded in file names
@file{@var{host-name}.@var{algorithm}.pub}. User names are always @code{nil}.
@item @code{tramp-parse-hosts}
-@findex tramp-parse-hosts
A function dedicated to @file{/etc/hosts} for host names.
@item @code{tramp-parse-passwd}
-@findex tramp-parse-passwd
A function which parses @file{/etc/passwd} for user names.
@item @code{tramp-parse-etc-group}
-@findex tramp-parse-etc-group
A function which parses @file{/etc/group} for group names.
@item @code{tramp-parse-netrc}
-@findex tramp-parse-netrc
A function which parses @file{~/.netrc} and @file{~/.authinfo}-style files.
-@end table
+@end ftable
To keep a custom file with custom data in a custom structure, a custom
function has to be provided. This function must meet the following
@@ -2913,6 +2904,7 @@ Additionally, it declares also the arguments for running remote
processes, using the @command{ssh} command. These don't need to be
changed.
+
@node Android shell setup
@section Android shell setup hints
@cindex android shell setup for ssh
@@ -4019,6 +4011,127 @@ using the @code{:connection-type} keyword. If this keyword is not
used, the value of @code{process-connection-type} is applied instead.
+@subsection Process properties of asynchronous remote processes
+@cindex Asynchronous remote processes
+
+When available, @value{tramp} adds process properties to process
+objects of asynchronous properties. However, it is not guaranteed
+that all these properties are set.
+
+@itemize
+@item @code{remote-tty}
+
+This is the name of the terminal a @var{process} uses on the remote
+host, i.e., it reads and writes on.
+
+@item @code{remote-pid}
+
+The process id of the command executed on the remote host. This is
+used when sending signals remotely.
+
+@item @code{remote-command}
+
+The remote command which has been invoked via @code{make-process} or
+@code{start-file-process}, a list of strings (program and its
+arguments). This does not show the additional shell sugar
+@value{tramp} makes around the commands, in order to see this you must
+inspect @value{tramp} @ref{Traces and Profiles, traces}.
+@end itemize
+
+@findex list-system-processes
+@findex process-attributes
+The functions @code{list-system-processes} and
+@code{process-attributes} return information about processes on the
+respective remote host. In order to retrieve this information, they
+use the command @command{ps}, driven by the following constants:
+
+@defvr Constant tramp-process-attributes-ps-args
+This is a list of arguments (strings) @command{ps} is called with.
+The default value is appropriate for GNU/Linux remote hosts.
+@end defvr
+
+@defvr Constant tramp-process-attributes-ps-format
+This is a list of cons cells @code{(@var{key} . @var{type})} for
+interpretation of the @command{ps} output. @var{key} is a key used in
+the @code{process-attributes} output plus the key @code{pid}, and
+@var{type} is the respective value returned by @command{ps}. It can
+be
+
+
+@multitable {@bullet{} @code{numberp}} {--- a string of @var{number} width, could contain spaces}
+@item @bullet{} @code{numberp} @tab --- a number
+@item @bullet{} @code{stringp} @tab --- a string without spaces
+@item @bullet{} @var{number}
+@tab --- a string of @var{number} width, could contain spaces
+@item @bullet{} @code{nil} @tab --- a string until end of line
+@end multitable
+
+The default value is appropriate for GNU/Linux remote hosts.
+@end defvr
+
+If, for example, @code{tramp-process-attributes-ps-args} is declared
+as @code{("-eww" "-o" "pid,euid,euser,egid,egroup,comm:40,state")},
+the output of the respective @command{ps} command would look like
+
+@smallexample
+@group
+ PID EUID EUSER EGID EGROUP COMMAND S
+ 1 0 root 0 root systemd S
+ 1610 0 root 0 root NFSv4 callback S
+ @dots{}
+@end group
+@end smallexample
+
+The corresponding @code{tramp-process-attributes-ps-format} has the value
+
+@smallexample
+@group
+@code{((pid . numberp) (euid . numberp) (user . stringp)
+ (egid . numberp) (group . stringp) (comm . 40) (state . stringp))}
+@end group
+@end smallexample
+
+@vindex tramp-adb-connection-local-default-ps-profile
+@vindex tramp-adb-connection-local-default-ps-variables
+@vindex tramp-connection-local-bsd-ps-profile
+@vindex tramp-connection-local-bsd-ps-variables
+@vindex tramp-connection-local-busybox-ps-profile
+@vindex tramp-connection-local-busybox-ps-variables
+@vindex tramp-connection-local-darwin-ps-profile
+@vindex tramp-connection-local-darwin-ps-variables
+The default values for @code{tramp-process-attributes-ps-args} and
+@code{tramp-process-attributes-ps-format} can be overwritten by
+connection-local variables.
+@ifinfo
+@xref{Connection Variables, , , emacs}.
+@end ifinfo
+This is already done by @value{tramp} for the @option{adb} method, see
+@code{tramp-adb-connection-local-default-ps-profile} and
+@code{tramp-adb-connection-local-default-ps-variables}.
+
+There are three further predefined sets of connection-local variables
+for remote BSD systems, for remote macOS systems, and for a remote
+@command{ps} command implemented with @command{busybox}. These are
+called @code{tramp-connection-local-*-ps-profile} and
+@code{tramp-connection-local-*-ps-variables}. Use them like
+
+@lisp
+@group
+(connection-local-set-profiles
+ '(:application tramp :machine "mybsdhost")
+ 'tramp-connection-local-bsd-ps-profile)
+@end group
+@end lisp
+
+@cindex proced
+@vindex proced-show-remote-processes
+If you want to see a listing of remote system processes when calling
+@code{proced}, set user option @code{proced-show-remote-processes} to
+non-@code{nil}, or invoke that command with a negative argument like
+@kbd{C-u - M-x proced @key{RET}} when your buffer has a remote
+@code{default-directory}.
+
+
@anchor{Improving performance of asynchronous remote processes}
@subsection Improving performance of asynchronous remote processes
@cindex Asynchronous remote processes
@@ -5001,6 +5114,26 @@ be restored by moving them manually from
@item
+How to identify temporary files produced by @value{tramp}?
+
+@vindex tramp-temp-name-prefix
+Temporary files are kept in your @code{temporary-file-directory}
+directory, which is often @file{/tmp/}. By default, they have the
+file name prefix @t{"tramp."}. If you want to change this prefix, for
+example because you want to identify temporary files produced by
+@code{file-local-copy} in your package, you can bind the variable
+@code{tramp-temp-name-prefix} temporarily:
+
+@example
+@group
+(let ((tramp-temp-name-prefix "my-prefix."))
+ (file-local-copy "@trampfn{ssh,,.emacs}"))
+@result{} "/tmp/my-prefix.HDfgDZ"
+@end group
+@end example
+
+
+@item
How to shorten long file names when typing in @value{tramp}?
Adapt several of these approaches to reduce typing. If the full name
diff --git a/etc/NEWS b/etc/NEWS
index f4d8756950b..79c27da5495 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -29,6 +29,7 @@ applies, and please also update docstrings as needed.
This uses the popular sqlite3 library, and can be disabled by using
the '--without-sqlite3' option to the 'configure' script.
++++
** Emacs has been ported to the Haiku operating system.
The configuration process should automatically detect and build for
Haiku. There is also an optional window-system port to Haiku, which
@@ -50,6 +51,7 @@ Unlike X, there is no compile-time option to enable or disable
double-buffering. If you wish to disable double-buffering, change the
frame parameter 'inhibit-double-buffering' instead.
+---
** Emacs now installs the ".pdmp" file using a unique fingerprint in the name.
The file is typically installed using a file name akin to
"...dir/libexec/emacs/29.1/x86_64-pc-linux-gnu/emacs-<fingerprint>.pdmp".
@@ -64,6 +66,7 @@ this support.
The named feature 'xinput2' can be used to test for the presence of
XInput 2 support from Lisp programs.
++++
** Emacs now supports being built with pure GTK.
To use this option, make sure the GTK 3 and Cairo development files
are installed, and configure Emacs with the option '--with-pgtk'.
@@ -80,6 +83,18 @@ input of sequences such as 'C-;' and 'C-S-u'.
Instead, they're fetched as needed from the corresponding ".elc" file,
as was already the case for all the non-preloaded files.
+** Emacs Sessions (Desktop)
+
++++
+*** New option to load a locked desktop if locking Emacs is not running.
+The option 'desktop-load-locked-desktop' can now be set to the value
+'check-pid', which means to allow loading a locked ".emacs.desktop"
+file if the Emacs process which locked it is no longer running on the
+local machine. This allows to avoid asking questions about locked
+desktop files when the Emacs session which locked it crashes or was
+otherwise interrupted and didn't exit gracefully. See the "(emacs)
+Saving Emacs Sessions" node in the Emacs manual for more details.
+
* Startup Changes in Emacs 29.1
@@ -117,8 +132,8 @@ If you have code in your init file that removes directories from
To get the previous action back, put something like the following in
your init file:
- (require 'ido)
- (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head)
+ (require 'ido)
+ (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head)
---
** New user option 'term-clear-full-screen-programs'.
@@ -154,6 +169,7 @@ example, if point is before an Emoji sequence, pressing <Delete> will
delete the entire sequence, not just a single character at its
beginning.
++++
** 'load-history' does not treat autoloads specially any more.
An autoload definition appears just as a '(defun . NAME)' and the
'(t . NAME)' entries are not generated any more.
@@ -174,6 +190,16 @@ methods instead.
If non-nil, this option allows dragging text in the region from Emacs
to another program.
+---
+** New user option 'mouse-drag-and-drop-region-scroll-margin'.
+If non-nil, this option allows scrolling a window while dragging text
+around without a scroll wheel.
+
++++
+** New user options 'dnd-indicate-insertion-point' and 'dnd-scroll-margin'.
+These options allow adjusting point and scrolling a window when
+dragging items from another program.
+
+++
** New function 'command-query'.
This function makes its argument command prompt the user for
@@ -195,6 +221,7 @@ If set to nil, commands like 'find-library' will only include library
files in the completion candidates. The default is t, which preserves
previous behavior, whereby non-library files could also be included.
++++
** New command 'sqlite-mode-open-file' for examining an sqlite3 file.
This uses the new 'sqlite-mode' which allows listing the tables in a
DB file, and examining and modifying the columns and the contents of
@@ -269,12 +296,22 @@ defaults to t, which makes Emacs use the toolkit tooltips. The
existing GTK-specific option 'x-gtk-use-system-tooltips' is now an
alias of this new option.
+** Connection-local variables
+
+++
-** Some connection-local variables are now user options.
+*** Some connection-local variables are now user options.
The variables 'connection-local-profile-alist' and
'connection-local-criteria-alist' are now user options, in order to
make it more convenient to inspect and modify them.
++++
+*** The default connection-local application can be changed temporarily.
+Running 'with-connection-local-variables' defaults to application
+'tramp'. This can be changed by let-binding
+'connection-local-default-application' to another symbol. This is
+useful when running code in a buffer, where Tramp has already set some
+connection local variables.
+
---
** New minor mode 'pixel-scroll-precision-mode'.
When enabled, and if your mouse supports it, you can scroll the
@@ -311,6 +348,7 @@ When environment variable 'EMACS_TEST_JUNIT_REPORT' is set, ERT
generates a JUnit test report under this file name. This is useful
for Emacs integration into CI/CD test environments.
+---
*** Unbound test symbols now signal an 'ert-test-unbound' error.
This affects the 'ert-select-tests' function and its callers.
@@ -344,6 +382,7 @@ inserted.
This command will tell you the name of the Emoji at point. (This
command also works for non-Emoji characters.)
+---
*** New input method 'emoji'.
** Help
@@ -371,6 +410,7 @@ displayed, if any.
** Outline Mode
++++
*** Support for customizing the default visibility state of headings.
Customize the user option 'outline-default-state' to define what
headings will be visible after Outline mode is turned on. When equal
@@ -408,7 +448,9 @@ For example, a 'display-buffer-alist' entry of
will make the body of the chosen window 40 columns wide. For the
height use 'window-height' in combination with 'body-lines'.
-*** 'other-window-scroll-default' can define the other window to scroll.
+---
+*** You can customize which window 'scroll-other-window' operates on.
+This is controlled by the new 'other-window-scroll-default' user option.
** Frames
@@ -430,6 +472,7 @@ the corresponding deleted frame.
By default, it contains 'C-c <left>' and 'C-c <right>' to browse
the history of tab window configurations back and forward.
+---
** Better detection of text suspiciously reordered on display.
The function 'bidi-find-overridden-directionality' has been extended
to detect reordering effects produced by embeddings and isolates
@@ -544,6 +587,12 @@ This uses the Tai Tham script, whose support has been enhanced.
* Changes in Specialized Modes and Packages in Emacs 29.1
---
+** kmacro
+Kmacros are now OClosures and have a new constructor 'kmacro' which
+uses the 'key-parse' syntax. It replaces the old 'kmacro-lambda-form'
+(which is now declared obsolete).
+
+---
** 'savehist.el' can now truncate variables that are too long.
An element of 'savehist-additional-variables' can now be of the form
'(VARIABLE . MAX-ELTS)', which means to truncate the VARIABLE's value to
@@ -552,10 +601,25 @@ value.
** Minibuffer and Completions
+*** New commands for navigating completions from the minibuffer.
+When the minibuffer is the current buffer, typing 'M-<up>' or
+'M-<down>' selects a previous/next completion candidate from the
+"*Completions*" buffer and inserts it to the minibuffer.
+When the variable 'minibuffer-completion-auto-choose' is nil,
+'M-<up>' and 'M-<down>' do the same, but without inserting
+a completion candidate to the minibuffer, then 'M-RET' can be used
+to choose the currently active candidate from the "*Completions*"
+buffer and exit the minibuffer. With a prefix argument, 'C-u M-RET'
+inserts the currently active candidate to the minibuffer, but doesn't
+exit the minibuffer.
+
++++
*** The "*Completions*" buffer can now be automatically selected.
To enable this behavior, customize the user option
-'completion-auto-select' to t. Then pressing 'TAB' will switch to the
-"*Completions*" buffer when it pops up that buffer.
+'completion-auto-select' to t, then pressing 'TAB' will switch to the
+"*Completions*" buffer when it pops up that buffer. If the value is
+'second-tab', then the first 'TAB' will display "*Completions*", and
+the second one will switch to the "*Completions*" buffer.
*** New user option 'completion-wrap-movement'.
When non-nil, the commands 'next-completion' and 'previous-completion'
@@ -567,6 +631,37 @@ This option controls the sorting of the completion candidates in
the "*Completions*" buffer. Available styles are no sorting,
alphabetical (the default), or a custom sort function.
++++
+*** New values for the 'completion-auto-help' user option.
+There are two new values to control the way the "*Completions*" buffer
+behaves after pressing a 'TAB' if completion is not unique. The value
+'always' updates or shows the "*Completions*" buffer after any attempt
+to complete. The value 'visual' is like 'always', but only updates
+the completions if they are already visible. The default value 't'
+always hides the completion buffer after some completion is made.
+
++++
+*** New user option 'completions-max-height'.
+This option limits the height of the "*Completions*" buffer.
+
++++
+*** New user option 'completions-header-format'.
+This is a string to control the heading line to show in the
+"*Completions*" buffer before the list of completions.
+If it contains "%s", that is replaced with the number of completions.
+If nil, the heading line is not shown.
+
++++
+*** New user option 'completions-highlight-face'.
+When this user option names a face, the current
+candidate in the "*Completions*" buffer is highlighted with that face.
+The nil value disables this highlighting.
+
+*** Choosing a completion with a prefix argument doesn't exit the minibuffer.
+This means that typing 'C-u RET' on a completion candidate in the
+"*Completions*" buffer inserts the completion to the minibuffer,
+bot doesn't exit the minibuffer.
+
** Isearch and Replace
+++
@@ -647,9 +742,9 @@ It narrows to the current node.
+++
*** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'.
-Rename 'eudc-expansion-overwrites-query' to
-'eudc-expansion-save-query-as-kill' to reflect the actual behaviour of
-the customization variable.
+'eudc-expansion-overwrites-query' is renamed to
+'eudc-expansion-save-query-as-kill' to reflect the actual behavior of
+the user option.
+++
*** New command 'eudc-expand-try-all'.
@@ -659,6 +754,26 @@ from all servers instead of just the matches from the first server to
return any. This is useful for example, if one wants to search LDAP
for a name that happens to match a contact in one's BBDB.
++++
+*** New behavior and default for user option 'eudc-inline-expansion-format'.
+EUDC inline expansion result formatting defaulted to
+
+ '("%s %s <%s>" firstname name email)
+
+Since email address specifications need to comply with RFC 5322 in
+order to be useful in messages, there was a risk to produce syntax
+which was standard with RFC 822, but is marked as obsolete syntax by
+its successor RFC 5322. Also, the first and last name part was never
+enclosed in double quotes, potentially producing invalid address
+specifications, which may be rejected by a receiving MTA. Thus, this
+variable can now additionally be set to nil (the new default), or a
+function. In both cases, the formatted result will be in compliance
+with RFC 5322. When set to nil, a default format very similar to the
+old default will be produced. When set to a function, that function
+is called, and the returned values are used to populate the phrase and
+comment parts (see RFC 5322 for definitions). In both cases, the
+phrase part will be automatically quoted if necessary.
+
** eww/shr
+++
@@ -704,6 +819,11 @@ displayed as emojis. Default nil.
This is bound to 'W D e' and will display symbols that have emoji
representation as emojis.
++++
+*** New mu backend for gnus-search.
+Configuration is very similar to the notmuch and namazu backends. It
+supports the unified search syntax.
+
** EIEIO
+++
@@ -932,6 +1052,12 @@ the thumbnail file.
** Dired
++++
+*** New user option 'dired-mouse-drag-files'.
+If non-nil, dragging file names with the mouse in a Dired buffer will
+initiate a drag-and-drop session allowing them to be opened in other
+programs.
+
*** New user option 'dired-free-space'.
Dired will now, by default, include the free space in the first line
instead of having it on a separate line. To get the previous behavior
@@ -995,7 +1121,7 @@ and friends.
---
*** Tramp supports abbreviating remote home directories now.
-When calling 'abbreviate-file-name' on a Tramp filename, the result
+When calling 'abbreviate-file-name' on a Tramp file name, the result
will abbreviate the user's home directory, for example by abbreviating
"/ssh:user@host:/home/user" to "/ssh:user@host:~".
@@ -1042,6 +1168,11 @@ support for pipelines which will move a lot of data. See section
** Miscellaneous
+++
+*** New user option 'font-lock-ignore'.
+This option provides a mechanism to selectively disable font-lock
+keyword-driven fontifications.
+
++++
*** New package vtable.el for formatting tabular data.
This package allows formatting data using variable-pitch fonts.
The resulting tables can display text in variable pitch fonts, text
@@ -1065,9 +1196,22 @@ This library provides the 'autoarg-mode' and 'autoarg-kp-mode' minor
modes to emulate the behavior of the historical editor Twenex Emacs.
It is believed to no longer be useful.
+---
+** proced.el shows system processes of remote hosts.
+When 'default-directory' is remote, and 'proced' is invoked with a
+negative argument like 'C-u - proced', the system processes of that
+remote host are shown. Alternatively, the user option
+'proced-show-remote-processes' can be set to non-nil.
+'proced-signal-function' has been marked obsolete.
+
* New Modes and Packages in Emacs 29.1
++++
+** New package 'oclosure'.
+Allows the creation of "functions with slots" or "function objects"
+via the macros 'oclosure-define' and 'oclosure-lambda'.
+
---
** New theme 'leuven-dark'.
This is a dark version of the 'leuven' theme.
@@ -1119,6 +1263,7 @@ a weight of 'normal' and the font doesn't have this weight, Emacs
won't find the font spec. In these cases, replacing ":weight 'normal"
with ":weight 'medium" should fix the issue.
+---
** Keymap descriptions have changed.
'help--describe-command', 'C-h b' and associated functions that output
keymap descriptions have changed. In particular, prefix commands are
@@ -1166,7 +1311,7 @@ like:
---
** The 'inhibit-changing-match-data' variable is now obsolete.
Instead, functions like 'string-match' and 'looking-at' now take an
-optional 'inhibit-modify' argument.
+optional INHIBIT-MODIFY argument.
---
** 'gnus-define-keys' is now obsolete.
@@ -1185,12 +1330,19 @@ Use 'exif-parse-file' and 'exif-field' instead.
** 'insert-directory' alternatives should not change the free disk space line.
This change is now applied in 'dired-insert-directory'.
+---
** Some functions and variables obsolete since Emacs 23 have been removed:
'find-emacs-lisp-shadows', 'newsticker-cache-filename',
'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode',
'vc-arch-command'.
+++
+** New generic function 'function-doumentation'.
+Can dynamically generate a raw docstring depending on the type of
+a function.
+Used mainly for docstrings of OClosures.
+
++++
** Base64 encoding no longer tolerates latin-1 input.
The functions 'base64-encode-string', 'base64url-encode-string',
'base64-encode-region' and 'base64url-encode-region' no longer accept
@@ -1209,6 +1361,21 @@ functions.
* Lisp Changes in Emacs 29.1
+++
+** 'macroexp-let2*' can omit 'test' arg and use single-var bindings.
+
++++
+** New variable 'last-event-device' and new function 'device-class'.
+On X Windows, 'last-event-device' specifies the input extension device
+from which the last input event originated, and 'device-class' can be
+used to determine the type of an input device.
+
++++
+** 'track-mouse' can be a new value 'drag-source'.
+This means the same as 'dropping', but modifies the mouse position
+list in reported motion events if there is no frame underneath the
+mouse pointer.
+
++++
** New function 'x-begin-drag'.
This function initiates a drag-and-drop request with the contents of
the selection 'XdndSelection', and returns when a drop occurs.
@@ -1286,6 +1453,13 @@ property.
This allows setting a minimum display width for a region of text.
+++
+** New 'cursor-face' text property.
+This uses 'cursor-face' instead of the default face when cursor is on or
+near the character and 'cursor-face-highlight-mode' is enabled. The
+user option 'cursor-face-highlight-nonselected-window' is similar to
+'highlight-nonselected-windows', but for this property.
+
++++
** New event type 'touch-end'.
This event is sent whenever the user's finger moves off the mouse
wheel on some mice, or when the user's finger moves off the touchpad.
@@ -1330,10 +1504,10 @@ option.
** Keymaps and key definitions
+++
-*** New functions for defining and manipulating keystrokes have been added.
-These all take just the syntax defined by 'key-valid-p'. None of the
-older functions have been depreciated or altered, but are deemphasised
-in the documentation.
+*** New functions for defining and manipulating keystrokes.
+These all take the syntax defined by 'key-valid-p'. None of the older
+functions have been deprecated or altered, but they are now
+de-emphasized in the documentation.
+++
*** Use 'keymap-set' instead of 'define-key'.
@@ -1421,6 +1595,11 @@ platforms.
This command lets you examine all data in the current selection and
the clipboard, and insert it into the buffer.
+---
+** New function 'minibuffer-lazy-highlight-setup'.
+This function allows setting up the minibuffer so that lazy
+highlighting of its content is applied in the original window.
+
+++
** New text property 'inhibit-isearch'.
If set, 'isearch' will skip these areas, which can be useful (for
@@ -1488,11 +1667,11 @@ from a specified amount of pixels above or below a position.
---
** 'eshell-eval-using-options' now follows POSIX/GNU argument syntax conventions.
Built-in commands in Eshell now accept command-line options with
-values passed as a single token, such as '-oVALUE' or
-'--option=VALUE'.
+values passed as a single token, such as '-oVALUE' or '--option=VALUE'.
** XDG support
+---
*** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable.
This new location, introduced in the XDG Base Directory Specification
version 0.8 (8th May 2021), "contains state data that should persist
@@ -1655,6 +1834,7 @@ that should be displayed, and the xwidget that asked to display it.
This function is used to control where and if an xwidget stores
cookies set by web pages on disk.
+---
** New variable 'help-buffer-under-preparation'.
This variable is bound to t during the preparation of a "*Help*" buffer.
@@ -1687,18 +1867,49 @@ The property ':position' now specifies the position of the underline
when used as part of a property list specification for the
':underline' attribute.
++++
** 'defalias' records a more precise history of definitions.
-This is recorded in the `function-history` symbol property.
+This is recorded in the 'function-history' symbol property.
---
** 'indian-tml-base-table' no longer translates digits.
Use 'indian-tml-base-digits-table' if you want digits translation.
---
+---
** 'indian-tml-itrans-v5-hash' no longer translates digits.
Use 'indian-tml-itrans-digits-v5-hash' if you want digits
translation.
++++
+** 'shell-quote-argument' has a new optional parameter POSIX.
+This is useful when quoting shell arguments for a remote shell
+invocation. Such shells are POSIX conform by default.
+
++++
+** 'signal-process' now consults the list 'signal-process-functions'.
+This is to determine which function has to be called in order to
+deliver the signal. This allows Tramp to send the signal to remote
+asynchronous processes. The hitherto existing implementation has been
+moved to 'signal-default-interrupt-process'.
+
++++
+** 'list-system-processes' returns remote process IDs now.
+This happens, when the current buffer's 'default-directory' is
+remote. In order to preserve the old behavior, apply
+
+ (let ((default-directory temporary-file-directory))
+ (list-system-processes))
+
++++
+** 'process-attributes' expects a remote process ID now.
+When current buffer's 'default-directory' is remote, the PID argument
+of 'process-attributes' is regarded as a remote process ID. In order
+to preserve the old behavior, apply
+
+ (let ((default-directory temporary-file-directory))
+ (process-attributes pid))
+
+
* Changes in Emacs 29.1 on Non-Free Operating Systems
@@ -1711,6 +1922,24 @@ follow the system's dark mode: GUI frames use the appropriate light or
dark title bar and scroll bars, based on the user's Windows-wide color
settings.
+---
+*** Emacs now uses native image APIs to display some image formats.
+On Windows 2000 and later, Emacs now defaults to using the native
+image APIs for displaying the BMP, GIF, JPEG, PNG, and TIFF images.
+This means Emacs on MS-Windows needs no longer use external image
+support libraries to display those images. Other image types -- XPM,
+SVG, and WEBP -- still need support libraries for Emacs to be able to
+display them.
+
+The use of native image APIs is controlled by the variable
+'w32-use-native-image-API', whose value now defaults to t on systems
+where those APIs are available.
+
++++
+*** Emacs now supports display of BMP images using native image APIs.
+When 'w32-use-native-image-API' is non-nil, Emacs on MS-Windows now
+has built-in support for displaying BMP images.
+
----------------------------------------------------------------------
This file is part of GNU Emacs.
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index 4e4ec6d353d..25022cad463 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -1786,6 +1786,21 @@ remote X server, try this:
(setq mouse-highlight nil)
+*** Dropping text on xterm doesn't work.
+
+Emacs sends sythetic button events to legacy clients such as xterm
+that do not support either the XDND or Motif drag-and-drop protocols
+in order to "paste" the text that was dropped. Unfortunately, xterm
+is configured to ignore these events by default. Add the following to
+your X defaults file to avoid the problem:
+
+ XTerm.*.allowSendEvents: True
+
+Note that this can in theory pose a security risk, but in pratice
+modern X servers have so many other ways to send input to clients
+without signifying that the event is synthesized that it does not
+matter.
+
* Runtime problems on character terminals
** The meta key does not work on xterm.
diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el
index f71962e3f16..be80b394102 100644
--- a/etc/themes/modus-operandi-theme.el
+++ b/etc/themes/modus-operandi-theme.el
@@ -1,10 +1,10 @@
-;;; modus-operandi-theme.el --- Accessible and customizable light theme (WCAG AAA) -*- lexical-binding:t -*-
+;;; modus-operandi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*-
;; Copyright (C) 2019-2022 Free Software Foundation, Inc.
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 2.2.0
+;; Version: 2.3.0
;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
@@ -56,17 +56,17 @@
(equal (file-name-directory load-file-name)
(expand-file-name "themes/" data-directory))
(require-theme 'modus-themes t))
- (require 'modus-themes)))
+ (require 'modus-themes))
-(deftheme modus-operandi
- "Accessible and customizable light theme (WCAG AAA standard).
+ (deftheme modus-operandi
+ "Elegant, highly legible and customizable light theme.
Conforms with the highest legibility standard for color contrast
between background and foreground in any given piece of text,
which corresponds to a minimum contrast in relative luminance of
-7:1.")
+7:1 (WCAG AAA standard).")
-(modus-themes-theme modus-operandi)
+ (modus-themes-theme modus-operandi)
-(provide-theme 'modus-operandi)
+ (provide-theme 'modus-operandi))
;;; modus-operandi-theme.el ends here
diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el
index 067fc22ee44..adec113bd21 100644
--- a/etc/themes/modus-themes.el
+++ b/etc/themes/modus-themes.el
@@ -1,11 +1,11 @@
-;;; modus-themes.el --- Highly accessible and customizable themes (WCAG AAA) -*- lexical-binding:t -*-
+;;; modus-themes.el --- Elegant, highly legible and customizable themes -*- lexical-binding:t -*-
;; Copyright (C) 2019-2022 Free Software Foundation, Inc.
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 2.2.0
-;; Last-Modified: <2022-02-23 08:56:46 +0200>
+;; Version: 2.3.0
+;; Last-Modified: <2022-04-01 12:33:34 +0300>
;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
@@ -41,6 +41,7 @@
;; modus-themes-bold-constructs (boolean)
;; modus-themes-deuteranopia (boolean)
;; modus-themes-inhibit-reload (boolean)
+;; modus-themes-intense-mouseovers (boolean)
;; modus-themes-italic-constructs (boolean)
;; modus-themes-mixed-fonts (boolean)
;; modus-themes-subtle-line-numbers (boolean)
@@ -123,6 +124,7 @@
;; deadgrep
;; debbugs
;; deft
+;; devdocs
;; dictionary
;; diff-hl
;; diff-mode
@@ -243,6 +245,7 @@
;; mct
;; mentor
;; messages
+;; mini-modeline
;; minimap
;; mmm-mode
;; mode-line
@@ -377,7 +380,10 @@
-(eval-when-compile (require 'cl-lib))
+(eval-when-compile
+ (require 'cl-lib)
+ (require 'subr-x))
+(require 'seq)
(defgroup modus-themes ()
"Options for `modus-operandi', `modus-vivendi'.
@@ -1611,17 +1617,17 @@ The actual styling of the face is done by `modus-themes-faces'."
(define-obsolete-face-alias
'modus-themes-completion-standard-first-match
- 'modus-themes-completion-selection
+ 'modus-themes-completion-selected
"2.2.0")
(define-obsolete-face-alias
'modus-themes-completion-standard-selected
- 'modus-themes-completion-selection
+ 'modus-themes-completion-selected
"2.2.0")
(define-obsolete-face-alias
'modus-themes-completion-extra-selected
- 'modus-themes-completion-selection
+ 'modus-themes-completion-selected
"2.2.0")
(define-obsolete-face-alias
@@ -1737,10 +1743,7 @@ For form, see `modus-themes-vivendi-colors'."
(put 'modus-themes-vivendi-color-overrides
'custom-options (copy-sequence colors)))
-(define-obsolete-variable-alias
- 'modus-themes-slanted-constructs
- 'modus-themes-italic-constructs
- "1.5.0")
+(defvaralias 'modus-themes-slanted-constructs 'modus-themes-italic-constructs)
(defcustom modus-themes-italic-constructs nil
"Use italic font forms in more code constructs."
@@ -1762,18 +1765,6 @@ For form, see `modus-themes-vivendi-colors'."
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Bold constructs"))
-(defcustom modus-themes-variable-pitch-headings nil
- "DEPRECATED: specify `variable-pitch' in `modus-themes-headings'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.0.0")
- :version "28.1"
- :type 'boolean
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Headings' typeface"))
-
-(make-obsolete 'modus-themes-variable-pitch-headings 'modus-themes-headings "2.0.0")
-
(defcustom modus-themes-variable-pitch-ui nil
"Use proportional fonts (variable-pitch) in UI elements.
This includes the mode line, header line, tab bar, and tab line."
@@ -1785,10 +1776,6 @@ This includes the mode line, header line, tab bar, and tab line."
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) UI typeface"))
-(define-obsolete-variable-alias
- 'modus-themes-no-mixed-fonts
- 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0")
-
(defcustom modus-themes-mixed-fonts nil
"Non-nil to enable inheritance from `fixed-pitch' in some faces.
@@ -1806,6 +1793,19 @@ Users may need to explicitly configure the font family of
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Mixed fonts"))
+(defcustom modus-themes-intense-mouseovers nil
+ "When non-nil use more intense style for mouse hover effects.
+
+This affects the generic `highlight' face which, strictly
+speaking, is not limited to mouse usage."
+ :group 'modus-themes
+ :package-version '(modus-themes . "2.3.0")
+ :version "29.1"
+ :type 'boolean
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Mouse hover effects"))
+
(defconst modus-themes--headings-choice
'(set :tag "Properties" :greedy t
(const :tag "Background color" background)
@@ -1823,7 +1823,11 @@ Users may need to explicitly configure the font family of
(const :tag "Semi-bold" semibold)
(const :tag "Extra-bold" extrabold)
(const :tag "Ultra-bold" ultrabold))
- (float :tag "Number (float) to adjust height by" :value 1.1)
+ (radio :tag "Height"
+ (float :tag "Floating point to adjust height by")
+ (cons :tag "Cons cell of `(height . FLOAT)'"
+ (const :tag "The `height' key (constant)" height)
+ (float :tag "Floating point")))
(choice :tag "Colors"
(const :tag "Subtle colors" nil)
(const :tag "Rainbow colors" rainbow)
@@ -1883,7 +1887,9 @@ weight instead.
A number, expressed as a floating point (e.g. 1.5), adjusts the
height of the heading to that many times the base font size. The
default height is the same as 1.0, though it need not be
-explicitly stated.
+explicitly stated. Instead of a floating point, an acceptable
+value can be in the form of a cons cell like (height . FLOAT)
+or (height FLOAT), where FLOAT is the given number.
Combinations of any of those properties are expressed as a list,
like in these examples:
@@ -1891,6 +1897,8 @@ like in these examples:
(semibold)
(rainbow background)
(overline monochrome semibold 1.3)
+ (overline monochrome semibold (height 1.3)) ; same as above
+ (overline monochrome semibold (height . 1.3)) ; same as above
The order in which the properties are set is not significant.
@@ -1920,7 +1928,7 @@ For Org users, the extent of the heading depends on the variable
and `background' properties. Depending on the version of Org,
there may be others, such as `org-fontify-done-headline'."
:group 'modus-themes
- :package-version '(modus-themes . "2.0.0")
+ :package-version '(modus-themes . "2.3.0")
:version "29.1"
:type `(alist
:options ,(mapcar (lambda (el)
@@ -1954,12 +1962,18 @@ font size. Acceptable values come in the form of a list that can
include either or both of those properties:
- `variable-pitch' to use a proportionately spaced typeface;
+
- A number as a floating point (e.g. 1.5) to set the height of
the text to that many times the default font height. A float
of 1.0 or the symbol `no-scale' have the same effect of making
- the font to the same height as the rest of the buffer. When
+ the font the same height as the rest of the buffer. When
neither a number nor `no-scale' are present, the default is a
small increase in height (a value of 1.15).
+
+ Instead of a floating point, an acceptable value can be in the
+ form of a cons cell like (height . FLOAT) or (height FLOAT),
+ where FLOAT is the given number.
+
- The symbol of a weight attribute adjusts the font of the
heading accordingly, such as `light', `semibold', etc. Valid
symbols are defined in the variable `modus-themes-weights'.
@@ -1987,17 +2001,24 @@ that can include any of the following properties:
- `grayscale' to make weekdays use the main foreground color and
weekends a more subtle gray;
+
- `workaholic' to make weekdays and weekends look the same in
terms of color;
+
- `bold-today' to apply a bold typographic weight to the current
date;
+
- `bold-all' to render all date headings in a bold weight;
+
- `underline-today' applies an underline to the current date
while removing the background it has by default;
+
- A number as a floating point (e.g. 1.2) to set the height of
the text to that many times the default font height. The
default is the same as the base font height (the equivalent of
- 1.0).
+ 1.0). Instead of a floating point, an acceptable value can be
+ in the form of a cons cell like (height . FLOAT) or (height
+ FLOAT), where FLOAT is the given number.
For example:
@@ -2085,7 +2106,7 @@ value are passed as a symbol. Those are:
highlights the alert and overdue states.
- When `modus-themes-deuteranopia' is non-nil the exact style of
the habit graph adapts to the needs of users with red-green
- colour deficiency by substituting every instance of green with
+ color deficiency by substituting every instance of green with
blue or cyan (depending on the specifics).
For example:
@@ -2094,7 +2115,7 @@ For example:
(habit . simplified)
(habit . traffic-light)"
:group 'modus-themes
- :package-version '(modus-themes . "2.1.0")
+ :package-version '(modus-themes . "2.3.0")
:version "29.1"
:type '(set
(cons :tag "Block header"
@@ -2115,10 +2136,14 @@ For example:
(const :tag "Semi-bold" semibold)
(const :tag "Extra-bold" extrabold)
(const :tag "Ultra-bold" ultrabold))
- (choice :tag "Scaling"
+ (radio :tag "Scaling"
(const :tag "Slight increase in height (default)" nil)
(const :tag "Do not scale" no-scale)
- (float :tag "Number (float) to adjust height by" :value 1.3))))
+ (radio :tag "Number (float) to adjust height by"
+ (float :tag "Just the number")
+ (cons :tag "Cons cell of `(height . FLOAT)'"
+ (const :tag "The `height' key (constant)" height)
+ (float :tag "Floating point"))))))
(cons :tag "Date header" :greedy t
(const header-date)
(set :tag "Header presentation" :greedy t
@@ -2126,8 +2151,12 @@ For example:
(const :tag "Do not differentiate weekdays from weekends" workaholic)
(const :tag "Make today bold" bold-today)
(const :tag "Make all dates bold" bold-all)
- (float :tag "Number (float) to adjust height by" :value 1.05)
- (const :tag "Make today underlined; remove the background" underline-today)))
+ (const :tag "Make today underlined; remove the background" underline-today)
+ (radio :tag "Number (float) to adjust height by"
+ (float :tag "Just the number")
+ (cons :tag "Cons cell of `(height . FLOAT)'"
+ (const :tag "The `height' key (constant)" height)
+ (float :tag "Floating point")))))
(cons :tag "Event entry" :greedy t
(const event)
(set :tag "Text presentation" :greedy t
@@ -2148,84 +2177,6 @@ For example:
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Org agenda"))
-(defcustom modus-themes-scale-headings nil
- "DEPRECATED: specify height in `modus-themes-headings'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
- :version "28.1"
- :type 'boolean
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-headings 'modus-themes-headings "2.0.0")
-
-(defcustom modus-themes-scale-1 1.05
- "DEPRECATED: specify height in `modus-themes-headings'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
- :version "28.1"
- :type 'number
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-1 'modus-themes-headings "2.0.0")
-
-(defcustom modus-themes-scale-2 1.1
- "DEPRECATED: specify height in `modus-themes-headings'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
- :version "28.1"
- :type 'number
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-2 'modus-themes-headings "2.0.0")
-
-(defcustom modus-themes-scale-3 1.15
- "DEPRECATED: specify height in `modus-themes-headings'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
- :version "28.1"
- :type 'number
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-3 'modus-themes-headings "2.0.0")
-
-(defcustom modus-themes-scale-4 1.2
- "DEPRECATED: specify height in `modus-themes-headings'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
- :version "28.1"
- :type 'number
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-4 'modus-themes-headings "2.0.0")
-
-(defcustom modus-themes-scale-title 1.3
- "DEPRECATED: specify height in `modus-themes-headings'.
-Same principle for `modus-themes-org-agenda'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
- :type 'number
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-title 'modus-themes-headings "2.0.0")
-
-(defcustom modus-themes-scale-small 0.9
- "DEPRECATED."
- :group 'modus-themes
- :package-version '(modus-themes . "1.6.0")
- :version "28.1"
- :type 'number
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default)
-
-(make-obsolete 'modus-themes-scale-small nil "2.0.0")
-
(defcustom modus-themes-fringes nil
"Define the visibility of fringes.
@@ -2395,6 +2346,17 @@ the `borderless' property is also set). For users on Emacs 29,
the `x-use-underline-position-properties' variable must also be
set to nil.
+The padding can also be expressed as a cons cell in the form
+of (padding . NATNUM) or (padding NATNUM) where the key is
+constant and NATNUM is the desired natural number.
+
+A floating point (e.g. 0.9) applies an adjusted height to the
+mode line's text as a multiple of the main font size. The
+default rate is 1.0 and does not need to be specified. Apart
+from a floating point, the height may also be expressed as a cons
+cell in the form of (height . FLOAT) or (height FLOAT) where the
+key is constant and the FLOAT is the desired number.
+
Combinations of any of those properties are expressed as a list,
like in these examples:
@@ -2402,6 +2364,13 @@ like in these examples:
(borderless 3d)
(moody accented borderless)
+Same as above, using the padding and height as an example (these
+all yield the same result):
+
+ (accented borderless 4 0.9)
+ (accented borderless (padding . 4) (height . 0.9))
+ (accented borderless (padding 4) (height 0.9))
+
The order in which the properties are set is not significant.
In user configuration files the form may look like this:
@@ -2433,8 +2402,8 @@ Furthermore, because Moody expects an underline and overline
instead of a box style, it is strongly advised to set
`x-underline-at-descent-line' to a non-nil value."
:group 'modus-themes
- :package-version '(modus-themes . "1.6.0")
- :version "28.1"
+ :package-version '(modus-themes . "2.3.0")
+ :version "29.1"
:type '(set :tag "Properties" :greedy t
(choice :tag "Overall style"
(const :tag "Rectangular Border" nil)
@@ -2442,23 +2411,20 @@ instead of a box style, it is strongly advised to set
(const :tag "No box effects (Moody-compatible)" moody))
(const :tag "Colored background" accented)
(const :tag "Without border color" borderless)
- (natnum :tag "With extra padding"))
+ (radio :tag "Padding"
+ (natnum :tag "Natural number (e.g. 4)")
+ (cons :tag "Cons cell of `(padding . NATNUM)'"
+ (const :tag "The `padding' key (constant)" padding)
+ (natnum :tag "Natural number")))
+ (radio :tag "Height"
+ (float :tag "Floating point (e.g. 0.9)")
+ (cons :tag "Cons cell of `(height . FLOAT)'"
+ (const :tag "The `height' key (constant)" height)
+ (float :tag "Floating point"))))
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Mode line"))
-(defcustom modus-themes-mode-line-padding 6
- "DEPRECATED: Set natural number in `modus-themes-mode-line'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.7.0")
- :version "29.1"
- :type 'natnum
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Mode line"))
-
-(make-obsolete 'modus-themes-mode-line-padding 'modus-themes-mode-line "2.0.0")
-
(defcustom modus-themes-diffs nil
"Adjust the overall style of diffs.
@@ -2525,11 +2491,15 @@ regardless of the order they may appear in:
The `selection' key applies to the current line or currently
matched candidate, depending on the specifics of the User
Interface. By default (nil or an empty list), it has a subtle
-gray background and a bold weight. The list of properties it
-accepts is as follows (order is not significant):
+gray background, a bold weight, and the base foreground value
+for the text. The list of properties it accepts is as
+follows (order is not significant):
- `accented' to make the background colorful instead of gray;
+- `text-also' to apply extra color to the text of the selected
+ line;
+
- `intense' to increase the overall coloration;
- `underline' to draw a line below the characters;
@@ -2560,7 +2530,8 @@ Is the same as:
In the case of the fallback, any property that does not apply to
the corresponding key is simply ignored (`matches' does not have
-`accented', `selection' and `popup' do not have `background').
+`accented' and `text-also', while `selection' and `popup' do not
+have `background').
A concise expression of those associations can be written as
follows, where the `car' is always the key and the `cdr' is the
@@ -2577,7 +2548,7 @@ node `(modus-themes) Configure bold and italic faces'.
Also refer to the Orderless documentation for its intersection
with Company (if you choose to use those in tandem)."
:group 'modus-themes
- :package-version '(modus-themes . "2.2.0")
+ :package-version '(modus-themes . "2.3.0")
:version "29.1"
:type `(set
(cons :tag "Matches"
@@ -2614,6 +2585,7 @@ with Company (if you choose to use those in tandem)."
(const :tag "Semi-bold" semibold)
(const :tag "Extra-bold" extrabold)
(const :tag "Ultra-bold" ultrabold))
+ (const :tag "Apply color to the line's text" text-also)
(const :tag "With accented background" accented)
(const :tag "Increased coloration" intense)
(const :tag "Italic font (oblique or slanted forms)" italic)
@@ -2633,6 +2605,7 @@ with Company (if you choose to use those in tandem)."
(const :tag "Semi-bold" semibold)
(const :tag "Extra-bold" extrabold)
(const :tag "Ultra-bold" ultrabold))
+ (const :tag "Apply color to the line's text" text-also)
(const :tag "With accented background" accented)
(const :tag "Increased coloration" intense)
(const :tag "Italic font (oblique or slanted forms)" italic)
@@ -2994,11 +2967,6 @@ In user configuration files the form may look like this:
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Active region"))
-(define-obsolete-variable-alias
- 'modus-themes-success-deuteranopia
- 'modus-themes-deuteranopia
- "2.0.0")
-
(defcustom modus-themes-deuteranopia nil
"When non-nil use red/blue color-coding instead of red/green.
@@ -3101,14 +3069,23 @@ defined in the variable `modus-themes-weights'.
A number, expressed as a floating point (e.g. 0.9), adjusts the
height of the button's text to that many times the base font
size. The default height is the same as 1.0, though it need not
-be explicitly stated.
+be explicitly stated. Instead of a floating point, an acceptable
+value can be in the form of a cons cell like (height . FLOAT)
+or (height FLOAT), where FLOAT is the given number.
+
+The `all-buttons' property extends the box button effect (or the
+aforementioned properties) to the faces of the generic widget
+library. By default, those do not look like the buttons of the
+Custom UI as they are ordinary text wrapped in square brackets.
Combinations of any of those properties are expressed as a list,
like in these examples:
(flat)
(variable-pitch flat)
- (variable-pitch flat 0.9 semibold)
+ (variable-pitch flat semibold 0.9)
+ (variable-pitch flat semibold (height 0.9)) ; same as above
+ (variable-pitch flat semibold (height . 0.9)) ; same as above
The order in which the properties are set is not significant.
@@ -3116,7 +3093,7 @@ In user configuration files the form may look like this:
(setq modus-themes-box-buttons (quote (variable-pitch flat 0.9)))"
:group 'modus-themes
- :package-version '(modus-themes . "2.1.0")
+ :package-version '(modus-themes . "2.3.0")
:version "29.1"
:type '(set :tag "Properties" :greedy t
(const :tag "Two-dimensional button" flat)
@@ -3124,6 +3101,7 @@ In user configuration files the form may look like this:
(const :tag "Reduce overall coloration" faint)
(const :tag "Proportionately spaced font (variable-pitch)" variable-pitch)
(const :tag "Underline instead of a box effect" underline)
+ (const :tag "Apply box button style to generic widget faces" all-buttons)
(choice :tag "Font weight (must be supported by the typeface)"
(const :tag "Thin" thin)
(const :tag "Ultra-light" ultralight)
@@ -3136,7 +3114,11 @@ In user configuration files the form may look like this:
(const :tag "Semi-bold" semibold)
(const :tag "Extra-bold" extrabold)
(const :tag "Ultra-bold" ultrabold))
- (float :tag "Number (float) to adjust height by" :value 0.9))
+ (radio :tag "Height"
+ (float :tag "Floating point to adjust height by")
+ (cons :tag "Cons cell of `(height . FLOAT)'"
+ (const :tag "The `height' key (constant)" height)
+ (float :tag "Floating point"))))
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Box buttons"))
@@ -3145,6 +3127,32 @@ In user configuration files the form may look like this:
;;; Internal functions
+(defun modus-themes--warn (option)
+ "Warn that OPTION has changed."
+ (prog1 nil
+ (display-warning
+ 'modus-themes
+ (format "`%s' has changed; please read the updated documentation" option)
+ :warning)))
+
+(defun modus-themes--list-or-warn (option)
+ "Return list or nil value of OPTION, else `modus-themes--warn'."
+ (let* ((value (symbol-value option)))
+ (if (or (null value) (listp value))
+ value
+ (modus-themes--warn option))))
+
+(defun modus-themes--alist-or-seq (properties alist-key seq-pred seq-default)
+ "Return value from alist or sequence.
+Check PROPERTIES for an alist value that corresponds to
+ALIST-KEY. If no alist is present, search the PROPERTIES
+sequence given SEQ-PRED, using SEQ-DEFAULT as a fallback."
+ (if-let* ((val (or (alist-get alist-key properties)
+ (seq-find seq-pred properties seq-default)))
+ ((listp val)))
+ (car val)
+ val))
+
(defun modus-themes--palette (theme)
"Return color palette for Modus theme THEME.
THEME is a symbol, either `modus-operandi' or `modus-vivendi'."
@@ -3183,8 +3191,9 @@ Those are stored in `modus-themes-faces' and
(custom-theme-set-variables ',name ,@modus-themes-custom-variables))))
(defun modus-themes--current-theme ()
- "Return current theme."
- (car custom-enabled-themes))
+ "Return current modus theme."
+ (car (seq-filter (lambda (arg) (string-match-p "^modus" (symbol-name arg)))
+ custom-enabled-themes)))
;; Helper functions that are meant to ease the implementation of the
;; above customization variables.
@@ -3269,45 +3278,36 @@ pattern and represent a value that is faint or vibrant
respectively. INTENSEFG-ALT is used when the intensity is high.
SUBTLEBG and INTENSEBG are color-coded background colors that
differ in overall intensity. FAINTFG is a nuanced color."
- (let ((modus-themes-lang-checkers
- (if (listp modus-themes-lang-checkers)
- modus-themes-lang-checkers
- (pcase modus-themes-lang-checkers
- ('colored-background '(background intense))
- ('intense-foreground '(intense))
- ('intense-foreground-straight-underline '(intense straight-underline))
- ('subtle-foreground '(text-also))
- ('subtle-foreground-straight-underline '(text-also straight-underline))
- ('straight-underline '(straight-underline))))))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-lang-checkers)))
(list :underline
(list :color
- (if (memq 'faint modus-themes-lang-checkers)
+ (if (memq 'faint properties)
faintfg underline)
:style
- (if (memq 'straight-underline modus-themes-lang-checkers)
+ (if (memq 'straight-underline properties)
'line 'wave))
:background
(cond
- ((and (memq 'background modus-themes-lang-checkers)
- (memq 'faint modus-themes-lang-checkers))
+ ((and (memq 'background properties)
+ (memq 'faint properties))
subtlebg)
- ((and (memq 'background modus-themes-lang-checkers)
- (memq 'intense modus-themes-lang-checkers))
+ ((and (memq 'background properties)
+ (memq 'intense properties))
intensebg)
- ((memq 'background modus-themes-lang-checkers)
+ ((memq 'background properties)
subtlebg)
('unspecified))
:foreground
(cond
- ((and (memq 'faint modus-themes-lang-checkers)
- (memq 'text-also modus-themes-lang-checkers))
+ ((and (memq 'faint properties)
+ (memq 'text-also properties))
faintfg)
- ((and (memq 'background modus-themes-lang-checkers)
- (memq 'intense modus-themes-lang-checkers))
+ ((and (memq 'background properties)
+ (memq 'intense properties))
intensefg-alt)
- ((memq 'intense modus-themes-lang-checkers)
+ ((memq 'intense properties)
intensefg)
- ((memq 'text-also modus-themes-lang-checkers)
+ ((memq 'text-also properties)
subtlefg)
('unspecified)))))
@@ -3326,7 +3326,7 @@ should be combinable with INTENSEBG-FG.
SUBTLEBGGRAY and INTENSEBGGRAY are background values. The former
can be combined with GRAYFG, while the latter only works with the
theme's fallback text color."
- (let ((properties modus-themes-prompts))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-prompts)))
(list :foreground
(cond
((and (memq 'gray properties)
@@ -3372,7 +3372,7 @@ NORMALBG should be the special palette color 'bg-paren-match' or
something similar. INTENSEBG must be easier to discern next to
other backgrounds, such as the special palette color
'bg-paren-match-intense'."
- (let ((properties modus-themes-paren-match))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-paren-match)))
(list :inherit
(if (memq 'bold properties)
'bold
@@ -3390,7 +3390,7 @@ other backgrounds, such as the special palette color
"Apply foreground value to code syntax.
FG is the default. FAINT is typically the same color in its
desaturated version."
- (let ((properties modus-themes-syntax))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax)))
(list :foreground
(cond
((memq 'faint properties)
@@ -3402,7 +3402,7 @@ desaturated version."
FG is the default. FAINT is typically the same color in its
desaturated version. ALT is another hue while optional FAINT-ALT
is its subtle alternative."
- (let ((properties modus-themes-syntax))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax)))
(list :foreground
(cond
((and (memq 'alt-syntax properties)
@@ -3421,7 +3421,7 @@ desaturated version. GREEN is a color variant in that side of
the spectrum. ALT is another hue. Optional FAINT-GREEN is a
subtle alternative to GREEN. Optional FAINT-ALT is a subtle
alternative to ALT."
- (let ((properties modus-themes-syntax))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax)))
(list :foreground
(cond
((and (memq 'faint properties)
@@ -3443,7 +3443,7 @@ alternative to ALT."
FG is the default. YELLOW is a color variant of that name while
optional FAINT-YELLOW is its subtle variant. Optional FAINT is
an alternative to the default value."
- (let ((properties modus-themes-syntax))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax)))
(list :foreground
(cond
((and (memq 'faint properties)
@@ -3521,7 +3521,7 @@ that combines well with the background and foreground."
fg-alt)
(fg))
:height
- (seq-find #'floatp properties 'unspecified)
+ (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified)
:weight
(or weight 'unspecified)
:overline
@@ -3546,7 +3546,7 @@ FG is the foreground color to use."
(or weight 'unspecified)
:height
(cond ((memq 'no-scale properties) 'unspecified)
- ((seq-find #'floatp properties 1.15)))
+ ((modus-themes--alist-or-seq properties 'height #'floatp 1.15)))
:foreground fg)))
(defun modus-themes--agenda-date (defaultfg grayscalefg &optional workaholicfg grayscaleworkaholicfg bg bold ul)
@@ -3581,7 +3581,7 @@ weight. Optional UL applies an underline."
(t
defaultfg))
:height
- (seq-find #'floatp properties 'unspecified)
+ (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified)
:underline
(if (and ul (memq 'underline-today properties))
t
@@ -3711,8 +3711,9 @@ line's box property.
Optional FG-DISTANT should be close to the main background
values. It is intended to be used as a distant-foreground
property."
- (let* ((properties modus-themes-mode-line)
- (padding (seq-find #'natnump properties 1))
+ (let* ((properties (modus-themes--list-or-warn 'modus-themes-mode-line))
+ (padding (modus-themes--alist-or-seq properties 'padding #'natnump 1))
+ (height (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified))
(padded (> padding 1))
(base (cond ((memq 'accented properties)
(cons fg-accent bg-accent))
@@ -3735,6 +3736,7 @@ property."
(border))))
(list :foreground (car base)
:background (cdr base)
+ :height height
:box
(cond ((memq 'moody properties)
'unspecified)
@@ -3807,26 +3809,21 @@ unspecified."
(list deuteran)
(list main)))
-(defun modus-themes--completion (key bg fg bgintense fgintense &optional bgaccent bgaccentintense)
+(make-obsolete 'modus-themes--completion 'modus-themes--completion-line "2.3.0")
+(make-obsolete 'modus-themes--completion 'modus-themes--completion-match "2.3.0")
+
+(defun modus-themes--completion-line (key bg fg bgintense fgintense &optional bgaccent bgaccentintense)
"Styles for `modus-themes-completions'.
KEY is the key of a cons cell. BG and FG are the main colors.
BGINTENSE works with the main foreground. FGINTENSE works on its
own. BGACCENT and BGACCENTINTENSE are colorful variants of the
other backgrounds."
- (let* ((var (if (listp modus-themes-completions)
- modus-themes-completions
- (prog1 nil
- (warn (concat "`modus-themes-completions' has changed."
- "\n"
- "Its value must now be an alist."
- "\n"
- "Please read the updated doc string.")))))
+ (let* ((var (modus-themes--list-or-warn 'modus-themes-completions))
(properties (or (alist-get key var) (alist-get t var)))
(popup (eq key 'popup))
(selection (eq key 'selection))
(line (or popup selection))
- (background (or line (memq 'background properties)))
- (base-fg (if selection fg 'unspecified))
+ (text (memq 'text-also properties))
(accented (memq 'accented properties))
(intense (memq 'intense properties))
(italic (memq 'italic properties))
@@ -3847,6 +3844,43 @@ other backgrounds."
bgaccentintense)
((and accented line)
bgaccent)
+ (intense bgintense)
+ (bg))
+ :foreground
+ (cond
+ ((and line text intense)
+ fgintense)
+ ((and line text)
+ fg)
+ ('unspecified))
+ :underline
+ (if (memq 'underline properties) t 'unspecified)
+ :weight
+ (if (and weight (null bold)) weight 'unspecified))))
+
+(defun modus-themes--completion-match (key bg fg bgintense fgintense)
+ "Styles for `modus-themes-completions'.
+KEY is the key of a cons cell. BG and FG are the main colors.
+BGINTENSE works with the main foreground. FGINTENSE works on its
+own."
+ (let* ((var (modus-themes--list-or-warn 'modus-themes-completions))
+ (properties (or (alist-get key var) (alist-get t var)))
+ (background (memq 'background properties))
+ (intense (memq 'intense properties))
+ (italic (memq 'italic properties))
+ (weight (modus-themes--weight properties))
+ (bold (when (and weight (eq weight 'bold)) 'bold)))
+ (list
+ :inherit
+ (cond
+ ((and italic weight (not (eq weight 'bold)))
+ 'italic)
+ ((and weight (not (eq weight 'bold)))
+ 'unspecified)
+ (italic 'bold-italic)
+ ('bold))
+ :background
+ (cond
((and background intense)
bgintense)
(background bg)
@@ -3854,7 +3888,7 @@ other backgrounds."
:foreground
(cond
((and background intense)
- base-fg)
+ 'unspecified)
(background fg)
(intense fgintense)
(fg))
@@ -3869,7 +3903,7 @@ FG is the link's default color for its text and underline
property. FGFAINT is a desaturated color for the text and
underline. UNDERLINE is a gray color only for the undeline. BG
is a background color and BGNEUTRAL is its fallback value."
- (let ((properties modus-themes-links))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-links)))
(list :inherit
(cond
((and (memq 'bold properties)
@@ -3907,7 +3941,7 @@ is a background color and BGNEUTRAL is its fallback value."
"Extend `modus-themes--link'.
FG is the main accented foreground. FGFAINT is also accented,
yet desaturated. Optional NEUTRALFG is a gray value."
- (let ((properties modus-themes-links))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-links)))
(list :foreground
(cond
((memq 'no-color properties)
@@ -3931,7 +3965,7 @@ is a subtle background value that can be combined with all colors
used to fontify text and code syntax. BGACCENT is a colored
background that combines well with FG. BGACCENTSUBTLE can be
combined with all colors used to fontify text."
- (let ((properties modus-themes-region))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-region)))
(list :background
(cond
((and (memq 'accented properties)
@@ -3967,7 +4001,7 @@ LINEACCENT are color values that can remain distinct against the
buffer's possible backgrounds: the former is neutral, the latter
is accented. LINENEUTRALINTENSE and LINEACCENTINTENSE are their
more prominent alternatives."
- (let ((properties modus-themes-hl-line))
+ (let ((properties (modus-themes--list-or-warn 'modus-themes-hl-line)))
(list :background
(cond
((and (memq 'intense properties)
@@ -4034,7 +4068,12 @@ application of a variable-pitch font."
(defun modus-themes--button (bg bgfaint bgaccent bgaccentfaint border &optional pressed-button-p)
"Apply `modus-themes-box-buttons' styles.
-Work in progress. BG BGFAINT BGACCENT BGACCENTFAINT BORDER PRESSED-BUTTON-P."
+BG is the main background. BGFAINT is its subtle alternative.
+BGACCENT is its accented variant and BGACCENTFAINT is the same
+but less intense. BORDER is the color around the box.
+
+When optional PRESSED-BUTTON-P is non-nil, the box uses the
+pressed button style, else the released button."
(let* ((properties modus-themes-box-buttons)
(weight (modus-themes--weight properties)))
(list :inherit
@@ -4075,7 +4114,7 @@ Work in progress. BG BGFAINT BGACCENT BGACCENTFAINT BORDER PRESSED-BUTTON-P."
(weight weight)
('unspecified))
:height
- (seq-find #'floatp properties 'unspecified)
+ (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified)
:underline
(if (memq 'underline properties)
t
@@ -4228,30 +4267,6 @@ as when they are declared in the `:config' phase)."
(defvar modus-themes-after-load-theme-hook nil
"Hook that runs after the `modus-themes-toggle' routines.")
-;; The reason we use `load-theme' instead of `enable-theme' is that the
-;; former does a kind of "reset" on the face specs. So it plays nicely
-;; with `custom-set-faces', as well as defcustom user customizations,
-;; including the likes of `modus-themes-operandi-color-overrides'.
-;;
-;; Tests show that `enable-theme' does not re-read those variables, so
-;; it might appear to the unsuspecting user that the themes are somehow
-;; broken.
-;;
-;; This "reset", however, comes at the cost of being a bit slower than
-;; `enable-theme'. User who have a stable setup and seldom update their
-;; variables during a given Emacs session, are better off using
-;; something like this:
-;;
-;; (defun modus-themes-toggle-enabled ()
-;; "Toggle between `modus-operandi' and `modus-vivendi' themes."
-;; (interactive)
-;; (pcase (modus-themes--current-theme)
-;; ('modus-operandi (progn (enable-theme 'modus-vivendi)
-;; (disable-theme 'modus-operandi)))
-;; ('modus-vivendi (progn (enable-theme 'modus-operandi)
-;; (disable-theme 'modus-vivendi)))
-;; (_ (error "No Modus theme is loaded; evaluate `modus-themes-load-themes' first"))))
-
;;;###autoload
(defun modus-themes-load-operandi ()
"Load `modus-operandi' and disable `modus-vivendi'.
@@ -4505,30 +4520,30 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(modus-themes-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t))))
;;;;; completion frameworks
`(modus-themes-completion-match-0
- ((,class ,@(modus-themes--completion
+ ((,class ,@(modus-themes--completion-match
'matches bg-special-faint-calm magenta-alt
magenta-subtle-bg magenta-intense))))
`(modus-themes-completion-match-1
- ((,class ,@(modus-themes--completion
+ ((,class ,@(modus-themes--completion-match
'matches bg-special-faint-cold cyan
cyan-subtle-bg cyan-intense))))
`(modus-themes-completion-match-2
- ((,class ,@(modus-themes--completion
+ ((,class ,@(modus-themes--completion-match
'matches bg-special-faint-mild green
green-subtle-bg green-intense))))
`(modus-themes-completion-match-3
- ((,class ,@(modus-themes--completion
+ ((,class ,@(modus-themes--completion-match
'matches bg-special-faint-warm yellow
yellow-subtle-bg orange-intense))))
`(modus-themes-completion-selected
- ((,class ,@(modus-themes--completion
- 'selection bg-inactive 'unspecified
- bg-active 'unspecified
+ ((,class ,@(modus-themes--completion-line
+ 'selection bg-inactive blue-alt
+ bg-active blue-active
bg-completion-subtle bg-completion))))
`(modus-themes-completion-selected-popup
- ((,class ,@(modus-themes--completion
- 'popup bg-active 'unspecified
- bg-region 'unspecified
+ ((,class ,@(modus-themes--completion-line
+ 'popup bg-active blue-alt
+ bg-region blue-active
cyan-subtle-bg cyan-refine-bg))))
;;;;; buttons
`(modus-themes-box-button
@@ -4568,6 +4583,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; basic and/or ungrouped styles
`(bold ((,class :weight bold)))
`(bold-italic ((,class :inherit (bold italic))))
+ `(underline ((,class :underline ,fg-alt)))
`(buffer-menu-buffer ((,class :inherit bold)))
`(child-frame-border ((,class :background ,fg-window-divider-inner)))
`(comint-highlight-input ((,class :inherit bold)))
@@ -4598,6 +4614,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
bg-hl-alt-intense bg-region-accent
bg-region-accent-subtle))))
`(secondary-selection ((,class :inherit modus-themes-special-cold)))
+ `(separator-line ((,class :underline ,bg-region)))
`(shadow ((,class :foreground ,fg-alt)))
`(success ((,class :inherit (bold modus-themes-grue))))
`(trailing-whitespace ((,class :background ,red-intense-bg)))
@@ -4611,8 +4628,12 @@ by virtue of calling either of `modus-themes-load-operandi' and
,@(modus-themes--link-color
magenta-alt-other magenta-alt-other-faint fg-alt))))
`(tooltip ((,class :background ,bg-special-cold :foreground ,fg-main)))
- `(widget-button ((,class :inherit bold :foreground ,blue-alt)))
- `(widget-button-pressed ((,class :inherit widget-button :foreground ,magenta)))
+ `(widget-button ((,class ,@(if (memq 'all-buttons modus-themes-box-buttons)
+ (list :inherit 'modus-themes-box-button)
+ (list :inherit 'bold :foreground blue-alt)))))
+ `(widget-button-pressed ((,class ,@(if (memq 'all-buttons modus-themes-box-buttons)
+ (list :inherit 'modus-themes-box-button-pressed)
+ (list :inherit 'bold :foreground magenta-alt)))))
`(widget-documentation ((,class :foreground ,green)))
`(widget-field ((,class :background ,bg-alt :foreground ,fg-main :extend nil)))
`(widget-inactive ((,class :inherit shadow :background ,bg-dim)))
@@ -4724,7 +4745,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(font-latex-string-face ((,class :inherit font-lock-string-face)))
`(font-latex-subscript-face ((,class :height 0.95)))
`(font-latex-superscript-face ((,class :height 0.95)))
- `(font-latex-verbatim-face ((,class :background ,bg-dim :foreground ,fg-special-mild)))
+ `(font-latex-verbatim-face ((,class :inherit modus-themes-markup-verbatim)))
`(font-latex-warning-face ((,class :inherit font-lock-warning-face)))
`(tex-match ((,class :foreground ,blue-alt-other)))
`(tex-verbatim ((,class :inherit modus-themes-markup-verbatim)))
@@ -4737,11 +4758,11 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(auto-dim-other-buffers-face ((,class :background ,bg-alt)))
;;;;; avy
`(avy-background-face ((,class :background ,bg-dim :foreground ,fg-dim :extend t)))
- `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-yellow bold))))
- `(avy-lead-face ((,class :inherit (modus-themes-intense-magenta bold modus-themes-reset-soft))))
- `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-cyan bold modus-themes-reset-soft))))
- `(avy-lead-face-1 ((,class :inherit (modus-themes-intense-neutral bold modus-themes-reset-soft))))
- `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-red bold modus-themes-reset-soft))))
+ `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-neutral bold))))
+ `(avy-lead-face ((,class :inherit (modus-themes-intense-blue bold modus-themes-reset-soft))))
+ `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-magenta bold modus-themes-reset-soft))))
+ `(avy-lead-face-1 ((,class :inherit (modus-themes-special-warm modus-themes-reset-soft))))
+ `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-green bold modus-themes-reset-soft))))
;;;;; aw (ace-window)
`(aw-background-face ((,class :foreground ,fg-unfocused)))
`(aw-key-face ((,class :inherit modus-themes-key-binding)))
@@ -4835,7 +4856,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(centaur-tabs-close-unselected ((,class :inherit centaur-tabs-unselected)))
`(centaur-tabs-modified-marker-selected ((,class :inherit centaur-tabs-selected)))
`(centaur-tabs-modified-marker-unselected ((,class :inherit centaur-tabs-unselected)))
- `(centaur-tabs-default (( )))
+ `(centaur-tabs-default ((,class :background ,bg-main)))
`(centaur-tabs-selected ((,class :inherit modus-themes-tab-active)))
`(centaur-tabs-selected-modified ((,class :inherit (italic centaur-tabs-selected))))
`(centaur-tabs-unselected ((,class :inherit modus-themes-tab-inactive)))
@@ -4926,7 +4947,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(company-preview-common ((,class :inherit company-echo-common)))
`(company-preview-search ((,class :inherit modus-themes-special-calm)))
`(company-template-field ((,class :inherit modus-themes-intense-magenta)))
- `(company-tooltip ((,class :background ,bg-alt :foreground ,fg-alt)))
+ `(company-tooltip ((,class :background ,bg-alt)))
`(company-tooltip-annotation ((,class :inherit completions-annotations)))
`(company-tooltip-common ((,class :inherit company-echo-common)))
`(company-tooltip-deprecated ((,class :inherit company-tooltip :strike-through t)))
@@ -5079,6 +5100,8 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(deft-summary-face ((,class :inherit (shadow modus-themes-slant))))
`(deft-time-face ((,class :foreground ,fg-special-cold)))
`(deft-title-face ((,class :inherit bold :foreground ,fg-main)))
+;;;;; devdocs
+ `(devdocs-code-block ((,class :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t)))
;;;;; dictionary
`(dictionary-button-face ((,class :inherit bold :foreground ,fg-special-cold)))
`(dictionary-reference-face ((,class :inherit button)))
@@ -5224,7 +5247,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(diredp-tagged-autofile-name ((,class :inherit modus-themes-refine-magenta)))
`(diredp-write-priv ((,class :foreground ,cyan)))
;;;;; display-fill-column-indicator-mode
- `(fill-column-indicator ((,class :foreground ,bg-active)))
+ `(fill-column-indicator ((,class :height 1 :background ,bg-inactive :foreground ,bg-inactive)))
;;;;; doom-modeline
`(doom-modeline-bar ((,class :inherit modus-themes-active-blue)))
`(doom-modeline-bar-inactive ((,class :background ,fg-inactive :foreground ,bg-main)))
@@ -5341,10 +5364,11 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(elpher-gemini-heading3 ((,class :inherit modus-themes-heading-3)))
;;;;; embark
`(embark-keybinding ((,class :inherit modus-themes-key-binding)))
+ `(embark-collect-marked ((,class :inherit modus-themes-mark-sel)))
;;;;; ement (ement.el)
`(ement-room-fully-read-marker ((,class :background ,cyan-subtle-bg)))
`(ement-room-membership ((,class :inherit shadow)))
- `(ement-room-mention (( )))
+ `(ement-room-mention ((,class :background ,bg-hl-alt-intense)))
`(ement-room-name ((,class :inherit bold)))
`(ement-room-reactions ((,class :inherit shadow)))
`(ement-room-read-receipt-marker ((,class :background ,yellow-subtle-bg)))
@@ -5910,7 +5934,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(hi-red-b ((,class :inherit bold :background ,red-intense-bg :foreground ,fg-main)))
`(hi-salmon ((,class :background ,red-subtle-bg :foreground ,fg-main)))
`(hi-yellow ((,class :background ,yellow-subtle-bg :foreground ,fg-main)))
- `(highlight ((,class :background ,cyan-subtle-bg :foreground ,fg-main)))
+ `(highlight ((,class ,@(if modus-themes-intense-mouseovers
+ (list :background blue-intense-bg :foreground fg-main)
+ (list :background cyan-subtle-bg :foreground fg-main)))))
`(highlight-changes ((,class :foreground ,red-alt :underline nil)))
`(highlight-changes-delete ((,class :background ,red-nuanced-bg
:foreground ,red :underline t)))
@@ -5942,7 +5968,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; icomplete-vertical
`(icomplete-vertical-separator ((,class :inherit shadow)))
;;;;; ido-mode
- `(ido-first-match ((,class :inherit modus-themes-completion-selected)))
+ `(ido-first-match ((,class :inherit modus-themes-completion-match-0)))
`(ido-incomplete-regexp ((,class :inherit error)))
`(ido-indicator ((,class :inherit modus-themes-subtle-yellow)))
`(ido-only-match ((,class :inherit ido-first-match)))
@@ -6436,6 +6462,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(message-header-xheader ((,class :foreground ,blue-alt)))
`(message-mml ((,class :foreground ,cyan-alt-other)))
`(message-separator ((,class :inherit modus-themes-intense-neutral)))
+;;;;; mini-modeline
+ `(mini-modeline-mode-line ((,class :background ,blue-intense :height 0.14)))
+ `(mini-modeline-mode-line-inactive ((,class :background ,fg-window-divider-inner :height 0.1)))
;;;;; minimap
`(minimap-active-region-background ((,class :background ,bg-active)))
`(minimap-current-line-face ((,class :background ,cyan-intense-bg :foreground ,fg-main)))
@@ -6459,7 +6488,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(mode-line-active ((,class :inherit mode-line)))
`(mode-line-buffer-id ((,class :inherit bold)))
`(mode-line-emphasis ((,class :inherit bold :foreground ,magenta-active)))
- `(mode-line-highlight ((,class :inherit highlight)))
+ `(mode-line-highlight ((,class ,@(if modus-themes-intense-mouseovers
+ (list :inherit 'modus-themes-active-blue)
+ (list :inherit 'highlight)))))
`(mode-line-inactive ((,class :inherit modus-themes-ui-variable-pitch
,@(modus-themes--mode-line-attrs
fg-inactive bg-inactive
@@ -6616,7 +6647,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; org
`(org-agenda-calendar-event ((,class ,@(modus-themes--agenda-event blue-alt))))
`(org-agenda-calendar-sexp ((,class ,@(modus-themes--agenda-event blue-alt t))))
- `(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend t)))
+ `(org-agenda-clocking ((,class :background ,yellow-nuanced-bg :foreground ,red-alt)))
`(org-agenda-column-dateline ((,class :background ,bg-alt)))
`(org-agenda-current-time ((,class :foreground ,blue-alt-other-faint)))
`(org-agenda-date ((,class ,@(modus-themes--agenda-date cyan fg-main))))
@@ -6650,7 +6681,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(org-checkbox (( )))
`(org-checkbox-statistics-done ((,class :inherit org-done)))
`(org-checkbox-statistics-todo ((,class :inherit org-todo)))
- `(org-clock-overlay ((,class :inherit modus-themes-special-cold)))
+ `(org-clock-overlay ((,class :background ,yellow-nuanced-bg :foreground ,red-alt-faint)))
`(org-code ((,class :inherit modus-themes-markup-code :extend t)))
`(org-column ((,class :inherit (modus-themes-fixed-pitch default)
:background ,bg-alt)))
@@ -6721,7 +6752,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(org-hide ((,class :foreground ,bg-main)))
`(org-indent ((,class :inherit (fixed-pitch org-hide))))
`(org-imminent-deadline ((,class :foreground ,red-intense)))
- `(org-latex-and-related ((,class :foreground ,magenta-refine-fg)))
+ `(org-latex-and-related ((,class :foreground ,magenta-faint)))
`(org-level-1 ((,class :inherit modus-themes-heading-1)))
`(org-level-2 ((,class :inherit modus-themes-heading-2)))
`(org-level-3 ((,class :inherit modus-themes-heading-3)))
@@ -7044,13 +7075,14 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(show-paren-match-expression ((,class :background ,bg-paren-expression)))
`(show-paren-mismatch ((,class :inherit modus-themes-intense-red)))
;;;;; shr
+ `(shr-abbreviation ((,class :inherit modus-themes-lang-note)))
+ `(shr-code ((,class :inherit modus-themes-markup-verbatim)))
`(shr-h1 ((,class :inherit modus-themes-heading-1)))
`(shr-h2 ((,class :inherit modus-themes-heading-2)))
`(shr-h3 ((,class :inherit modus-themes-heading-3)))
`(shr-h4 ((,class :inherit modus-themes-heading-4)))
`(shr-h5 ((,class :inherit modus-themes-heading-5)))
`(shr-h6 ((,class :inherit modus-themes-heading-6)))
- `(shr-abbreviation ((,class :inherit modus-themes-lang-note)))
`(shr-selected-link ((,class :inherit modus-themes-subtle-red)))
;;;;; side-notes
`(side-notes ((,class :background ,bg-dim :foreground ,fg-dim)))
@@ -7428,8 +7460,8 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; vertico
`(vertico-current ((,class :inherit modus-themes-completion-selected)))
;;;;; vertico-quick
- `(vertico-quick1 ((,class :inherit (modus-themes-intense-magenta bold))))
- `(vertico-quick2 ((,class :inherit (modus-themes-refine-cyan bold))))
+ `(vertico-quick1 ((,class :inherit (modus-themes-intense-blue bold))))
+ `(vertico-quick2 ((,class :inherit (modus-themes-refine-magenta bold))))
;;;;; vimish-fold
`(vimish-fold-fringe ((,class :foreground ,cyan-active)))
`(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue)))
@@ -7645,6 +7677,8 @@ by virtue of calling either of `modus-themes-load-operandi' and
("XXX+" . ,red-alt)
("REVIEW" . ,cyan-alt-other)
("DEPRECATED" . ,blue-nuanced-fg)))
+;;;; mini-modeline
+ `(mini-modeline-face-attr '(:background unspecified))
;;;; pdf-tools
`(pdf-view-midnight-colors
'(,fg-main . ,bg-dim))
@@ -7671,6 +7705,20 @@ by virtue of calling either of `modus-themes-load-operandi' and
(340 . ,blue-alt-other)
(360 . ,magenta-alt-other)))
`(vc-annotate-very-old-color nil)
+;;;; wid-edit
+ `(widget-link-prefix ,(if (memq 'all-buttons modus-themes-box-buttons)
+ " "
+ "["))
+ `(widget-link-suffix ,(if (memq 'all-buttons modus-themes-box-buttons)
+ " "
+ "]"))
+ `(widget-mouse-face '(highlight widget-button))
+ `(widget-push-button-prefix ,(if (memq 'all-buttons modus-themes-box-buttons)
+ " "
+ "["))
+ `(widget-push-button-suffix ,(if (memq 'all-buttons modus-themes-box-buttons)
+ " "
+ "]"))
;;;; xterm-color
`(xterm-color-names ["black" ,red ,green ,yellow ,blue ,magenta ,cyan "gray65"])
`(xterm-color-names-bright ["gray35" ,red-alt ,green-alt ,yellow-alt ,blue-alt ,magenta-alt ,cyan-alt "white"])
diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el
index 7d38e5cbf27..fb95772654f 100644
--- a/etc/themes/modus-vivendi-theme.el
+++ b/etc/themes/modus-vivendi-theme.el
@@ -1,10 +1,10 @@
-;;; modus-vivendi-theme.el --- Accessible and customizable dark theme (WCAG AAA) -*- lexical-binding:t -*-
+;;; modus-vivendi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*-
;; Copyright (C) 2019-2022 Free Software Foundation, Inc.
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 2.2.0
+;; Version: 2.3.0
;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
@@ -56,17 +56,17 @@
(equal (file-name-directory load-file-name)
(expand-file-name "themes/" data-directory))
(require-theme 'modus-themes t))
- (require 'modus-themes)))
+ (require 'modus-themes))
-(deftheme modus-vivendi
- "Accessible and customizable dark theme (WCAG AAA standard).
+ (deftheme modus-vivendi
+ "Elegant, highly legible and customizable dark theme.
Conforms with the highest legibility standard for color contrast
between background and foreground in any given piece of text,
which corresponds to a minimum contrast in relative luminance of
-7:1.")
+7:1 (WCAG AAA standard).")
-(modus-themes-theme modus-vivendi)
+ (modus-themes-theme modus-vivendi)
-(provide-theme 'modus-vivendi)
+ (provide-theme 'modus-vivendi))
;;; modus-vivendi-theme.el ends here
diff --git a/leim/Makefile.in b/leim/Makefile.in
index 6cf0abb40ca..4e70e8b7e9d 100644
--- a/leim/Makefile.in
+++ b/leim/Makefile.in
@@ -131,6 +131,7 @@ ${leimdir}/ja-dic/ja-dic.el: | $(leimdir)/ja-dic
${leimdir}/ja-dic/ja-dic.el: $(srcdir)/SKK-DIC/SKK-JISYO.L
$(AM_V_GEN)$(RUN_EMACS) -batch -l ja-dic-cnv \
+ --eval "(setq max-specpdl-size 5000)" \
-f batch-skkdic-convert -dir "$(leimdir)/ja-dic" "$<"
${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map
diff --git a/lib-src/ebrowse.c b/lib-src/ebrowse.c
index b77572734fe..641570da02e 100644
--- a/lib-src/ebrowse.c
+++ b/lib-src/ebrowse.c
@@ -1209,17 +1209,14 @@ sym_scope (struct sym *p)
}
-/* Dump the list of members M to file FP. Value is the length of the
- list. */
+/* Dump the list of members M to file FP. */
-static int
+static void
dump_members (FILE *fp, struct member *m)
{
- int n;
-
putc ('(', fp);
- for (n = 0; m; m = m->next, ++n)
+ for (; m; m = m->next)
{
fputs (MEMBER_STRUCT, fp);
putstr (m->name, fp);
@@ -1239,7 +1236,6 @@ dump_members (FILE *fp, struct member *m)
putc (')', fp);
putc ('\n', fp);
- return n;
}
@@ -1268,15 +1264,11 @@ dump_sym (FILE *fp, struct sym *root)
}
-/* Dump class ROOT and its subclasses to file FP. Value is the
- number of classes written. */
+/* Dump class ROOT and its subclasses to file FP. */
-static int
+static void
dump_tree (FILE *fp, struct sym *root)
{
- struct link *lk;
- unsigned n = 0;
-
dump_sym (fp, root);
if (f_verbose)
@@ -1287,20 +1279,20 @@ dump_tree (FILE *fp, struct sym *root)
putc ('(', fp);
- for (lk = root->subs; lk; lk = lk->next)
+ for (struct link *lk = root->subs; lk; lk = lk->next)
{
fputs (TREE_STRUCT, fp);
- n += dump_tree (fp, lk->sym);
+ dump_tree (fp, lk->sym);
putc (']', fp);
}
putc (')', fp);
dump_members (fp, root->vars);
- n += dump_members (fp, root->fns);
+ dump_members (fp, root->fns);
dump_members (fp, root->static_vars);
- n += dump_members (fp, root->static_fns);
- n += dump_members (fp, root->friends);
+ dump_members (fp, root->static_fns);
+ dump_members (fp, root->friends);
dump_members (fp, root->types);
/* Superclasses. */
@@ -1312,7 +1304,6 @@ dump_tree (FILE *fp, struct sym *root)
putc (')', fp);
putc ('\n', fp);
- return n;
}
@@ -1321,9 +1312,6 @@ dump_tree (FILE *fp, struct sym *root)
static void
dump_roots (FILE *fp)
{
- int i, n = 0;
- struct sym *r;
-
/* Output file header containing version string, command line
options etc. */
if (!f_append)
@@ -1347,12 +1335,12 @@ dump_roots (FILE *fp)
mark_inherited_virtual ();
/* Dump the roots of the graph. */
- for (i = 0; i < TABLE_SIZE; ++i)
- for (r = class_table[i]; r; r = r->next)
+ for (int i = 0; i < TABLE_SIZE; ++i)
+ for (struct sym *r = class_table[i]; r; r = r->next)
if (!r->supers)
{
fputs (TREE_STRUCT, fp);
- n += dump_tree (fp, r);
+ dump_tree (fp, r);
putc (']', fp);
}
diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h
index 3e0c302af33..9270ced8973 100644
--- a/lib/fcntl.in.h
+++ b/lib/fcntl.in.h
@@ -435,6 +435,10 @@ _GL_WARN_ON_USE (openat, "openat is not portable - "
# define AT_EACCESS 4
#endif
+/* Ignore this flag if not supported. */
+#ifndef AT_NO_AUTOMOUNT
+# define AT_NO_AUTOMOUNT 0
+#endif
#endif /* _@GUARD_PREFIX@_FCNTL_H */
#endif /* _@GUARD_PREFIX@_FCNTL_H */
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index 3deeca98bef..bbb05fdba50 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -931,6 +931,7 @@ LIB_EXECINFO = @LIB_EXECINFO@
LIB_GETRANDOM = @LIB_GETRANDOM@
LIB_HAS_ACL = @LIB_HAS_ACL@
LIB_MATH = @LIB_MATH@
+LIB_NANOSLEEP = @LIB_NANOSLEEP@
LIB_PTHREAD = @LIB_PTHREAD@
LIB_PTHREAD_SIGMASK = @LIB_PTHREAD_SIGMASK@
LIB_TIMER_TIME = @LIB_TIMER_TIME@
@@ -1238,6 +1239,8 @@ WINDRES = @WINDRES@
WINT_T_SUFFIX = @WINT_T_SUFFIX@
XARGS_LIMIT = @XARGS_LIMIT@
XCB_LIBS = @XCB_LIBS@
+XCOMPOSITE_CFLAGS = @XCOMPOSITE_CFLAGS@
+XCOMPOSITE_LIBS = @XCOMPOSITE_LIBS@
XCRUN = @XCRUN@
XDBE_CFLAGS = @XDBE_CFLAGS@
XDBE_LIBS = @XDBE_LIBS@
@@ -1256,6 +1259,8 @@ XOBJ = @XOBJ@
XRANDR_CFLAGS = @XRANDR_CFLAGS@
XRANDR_LIBS = @XRANDR_LIBS@
XRENDER_LIBS = @XRENDER_LIBS@
+XSHAPE_CFLAGS = @XSHAPE_CFLAGS@
+XSHAPE_LIBS = @XSHAPE_LIBS@
XSYNC_CFLAGS = @XSYNC_CFLAGS@
XSYNC_LIBS = @XSYNC_LIBS@
XWIDGETS_OBJ = @XWIDGETS_OBJ@
diff --git a/lib/mini-gmp-gnulib.c b/lib/mini-gmp-gnulib.c
index a18ee8f6ab7..7d09c80e9e9 100644
--- a/lib/mini-gmp-gnulib.c
+++ b/lib/mini-gmp-gnulib.c
@@ -40,7 +40,8 @@
#endif
/* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */
-#if defined NDEBUG && 4 < __GNUC__ + (6 <= __GNUC_MINOR__)
+#if (defined NDEBUG \
+ && (4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__))
# pragma GCC diagnostic ignored "-Wunused-variable"
#endif
diff --git a/lib/mini-gmp.c b/lib/mini-gmp.c
index e7a320a6420..2b1ddee079b 100644
--- a/lib/mini-gmp.c
+++ b/lib/mini-gmp.c
@@ -10,7 +10,7 @@ The GNU MP Library is free software; you can redistribute it and/or modify
it under the terms of either:
* the GNU Lesser General Public License as published by the Free
- Software Foundation, either version 3 of the License, or (at your
+ Software Foundation; either version 3 of the License, or (at your
option) any later version.
or
@@ -1937,9 +1937,8 @@ mpz_neg (mpz_t r, const mpz_t u)
void
mpz_swap (mpz_t u, mpz_t v)
{
- MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size);
MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc);
- MP_PTR_SWAP (u->_mp_d, v->_mp_d);
+ MPN_PTR_SWAP (u->_mp_d, u->_mp_size, v->_mp_d, v->_mp_size);
}
diff --git a/lib/openat.h b/lib/openat.h
index 5c8ff90b804..56919ef8dc4 100644
--- a/lib/openat.h
+++ b/lib/openat.h
@@ -98,12 +98,14 @@ lchmodat (int fd, char const *file, mode_t mode)
# define STATAT_INLINE _GL_INLINE
# endif
+_GL_ATTRIBUTE_DEPRECATED
STATAT_INLINE int
statat (int fd, char const *name, struct stat *st)
{
return fstatat (fd, name, st, 0);
}
+_GL_ATTRIBUTE_DEPRECATED
STATAT_INLINE int
lstatat (int fd, char const *name, struct stat *st)
{
diff --git a/lib/regex_internal.c b/lib/regex_internal.c
index 3945ee7ecbf..0e6919f3400 100644
--- a/lib/regex_internal.c
+++ b/lib/regex_internal.c
@@ -1396,24 +1396,22 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token)
if (__glibc_unlikely (new_nodes == NULL))
return -1;
dfa->nodes = new_nodes;
+ dfa->nodes_alloc = new_nodes_alloc;
new_nexts = re_realloc (dfa->nexts, Idx, new_nodes_alloc);
+ if (new_nexts != NULL)
+ dfa->nexts = new_nexts;
new_indices = re_realloc (dfa->org_indices, Idx, new_nodes_alloc);
+ if (new_indices != NULL)
+ dfa->org_indices = new_indices;
new_edests = re_realloc (dfa->edests, re_node_set, new_nodes_alloc);
+ if (new_edests != NULL)
+ dfa->edests = new_edests;
new_eclosures = re_realloc (dfa->eclosures, re_node_set, new_nodes_alloc);
+ if (new_eclosures != NULL)
+ dfa->eclosures = new_eclosures;
if (__glibc_unlikely (new_nexts == NULL || new_indices == NULL
|| new_edests == NULL || new_eclosures == NULL))
- {
- re_free (new_nexts);
- re_free (new_indices);
- re_free (new_edests);
- re_free (new_eclosures);
- return -1;
- }
- dfa->nexts = new_nexts;
- dfa->org_indices = new_indices;
- dfa->edests = new_edests;
- dfa->eclosures = new_eclosures;
- dfa->nodes_alloc = new_nodes_alloc;
+ return -1;
}
dfa->nodes[dfa->nodes_len] = token;
dfa->nodes[dfa->nodes_len].constraint = 0;
diff --git a/lib/regexec.c b/lib/regexec.c
index aea1e7da52c..521cb028415 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -1308,8 +1308,8 @@ push_fail_stack (struct re_fail_stack_t *fs, Idx str_idx, Idx dest_node,
re_node_set *eps_via_nodes)
{
reg_errcode_t err;
- Idx num = fs->num++;
- if (fs->num == fs->alloc)
+ Idx num = fs->num;
+ if (num == fs->alloc)
{
struct re_fail_stack_ent_t *new_array;
new_array = re_realloc (fs->stack, struct re_fail_stack_ent_t,
@@ -1324,6 +1324,7 @@ push_fail_stack (struct re_fail_stack_t *fs, Idx str_idx, Idx dest_node,
fs->stack[num].regs = re_malloc (regmatch_t, 2 * nregs);
if (fs->stack[num].regs == NULL)
return REG_ESPACE;
+ fs->num = num + 1;
memcpy (fs->stack[num].regs, regs, sizeof (regmatch_t) * nregs);
memcpy (fs->stack[num].regs + nregs, prevregs, sizeof (regmatch_t) * nregs);
err = re_node_set_init_copy (&fs->stack[num].eps_via_nodes, eps_via_nodes);
diff --git a/lisp/align.el b/lisp/align.el
index b054b1bac47..9364d546654 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -546,15 +546,16 @@ The possible settings for `align-region-separate' are:
(regexp . "\\(\\s-*\\)\\\\\\\\")
(modes . align-tex-modes))
- ;; With a numeric prefix argument, or C-u, space delimited text
- ;; tables will be aligned.
+ ;; Align space delimited text as columns.
(text-column
(regexp . "\\(^\\|\\S-\\)\\([ \t]+\\)\\(\\S-\\|$\\)")
(group . 2)
(modes . align-text-modes)
(repeat . t)
(run-if . ,(lambda ()
- (not (eq '- current-prefix-arg)))))
+ (and (not (eq '- current-prefix-arg))
+ (not (apply #'provided-mode-derived-p
+ major-mode align-tex-modes))))))
;; With a negative prefix argument, lists of dollar figures will
;; be aligned.
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 4f0edbbfa98..f1a3735d2c6 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -1340,7 +1340,8 @@ NEW-NAME."
t)
(defun archive-*-write-file-member (archive descr command)
- (let* ((ename (archive--file-desc-ext-file-name descr))
+ (let* ((archive (expand-file-name archive))
+ (ename (archive--file-desc-ext-file-name descr))
(tmpfile (expand-file-name ename archive-tmpdir))
(top (directory-file-name (file-name-as-directory archive-tmpdir)))
(default-directory (file-name-as-directory top)))
@@ -1364,6 +1365,7 @@ NEW-NAME."
(setq ename
(encode-coding-string ename archive-file-name-coding-system))
(let* ((coding-system-for-write 'no-conversion)
+ (default-directory (file-name-as-directory archive-tmpdir))
(exitcode (apply #'call-process
(car command)
nil
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index cb528cebdcd..cd135bd2e2c 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -573,19 +573,24 @@ which says:
or P. The resulting token will only have keys user, host, and
port.\"
-:create \\='(A B C) also means to create a token if possible.
+:create \\='(A B C) or
+:create \\='(:unencrypted A B :encrypted C)
+also means to create a token if possible.
The behavior is like :create t but if the list contains any
parameter, that parameter will be required in the resulting
-token. The value for that parameter will be obtained from the
-search parameters or from user input. If any queries are needed,
-the alist `auth-source-creation-defaults' will be checked for the
-default value. If the user, host, or port are missing, the alist
-`auth-source-creation-prompts' will be used to look up the
-prompts IN THAT ORDER (so the `user' prompt will be queried first,
-then `host', then `port', and finally `secret'). Each prompt string
-can use %u, %h, and %p to show the user, host, and port. The prompt
-is formatted with `format-prompt', a trailing \": \" is removed.
+token (the second form is used only with the plstore backend and
+specifies if any of the extra parameters should be stored in
+encrypted format.) The value for that parameter will be obtained
+from the search parameters or from user input. If any queries
+are needed, the alist `auth-source-creation-defaults' will be
+checked for the default value. If the user, host, or port are
+missing, the alist `auth-source-creation-prompts' will be used to
+look up the prompts IN THAT ORDER (so the `user' prompt will be
+queried first, then `host', then `port', and finally `secret').
+Each prompt string can use %u, %h, and %p to show the user, host,
+and port. The prompt is formatted with `format-prompt', a
+trailing \": \" is removed.
Here's an example:
@@ -2131,12 +2136,17 @@ entries for git.gnus.org:
(let* ((base-required '(host user port secret))
(base-secret '(secret))
;; we know (because of an assertion in auth-source-search) that the
- ;; :create parameter is either t or a list (which includes nil)
- (create-extra (if (eq t create) nil create))
+ ;; :create parameter is either t, or a list (which includes nil
+ ;; or a plist)
+ (create-extra-secret (plist-get create :encrypted))
+ (create-extra (if (eq t create) nil
+ (or (append (plist-get create :unencrypted)
+ create-extra-secret) create)))
(current-data (car (auth-source-search :max 1
:host host
:port port)))
(required (append base-required create-extra))
+ (required-secret (append base-secret create-extra-secret))
;; `valist' is an alist
valist
;; `artificial' will be returned if no creation is needed
@@ -2158,10 +2168,11 @@ entries for git.gnus.org:
(auth-source--aput valist br br-choice))))))
;; for extra required elements, see if the spec includes a value for them
- (dolist (er create-extra)
- (let ((k (auth-source--symbol-keyword er))
- (keys (cl-loop for i below (length spec) by 2
- collect (nth i spec))))
+ (let ((keys (cl-loop for i below (length spec) by 2
+ collect (nth i spec)))
+ k)
+ (dolist (er create-extra)
+ (setq k (auth-source--symbol-keyword er))
(when (memq k keys)
(auth-source--aput valist er (plist-get spec k)))))
@@ -2225,7 +2236,7 @@ entries for git.gnus.org:
(eval default)))))
(when data
- (if (member r base-secret)
+ (if (member r required-secret)
(setq secret-artificial
(plist-put secret-artificial
(auth-source--symbol-keyword r)
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index f60aa9be6fa..d25275e3ec4 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -89,9 +89,10 @@ If this contains a %s, that will be replaced by the matching rule."
:type 'string
:version "28.1")
+(declare-function sgml-tag "sgml-mode" (&optional str arg))
(defcustom auto-insert-alist
- '((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header")
+ `((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header")
(replace-regexp-in-string
"[^A-Z0-9]" "_"
(string-replace
@@ -113,7 +114,7 @@ If this contains a %s, that will be replaced by the matching rule."
(("[Mm]akefile\\'" . "Makefile") . "makefile.inc")
- (html-mode . (lambda () (sgml-tag "html")))
+ (html-mode . ,(lambda () (sgml-tag "html")))
(plain-tex-mode . "tex-insert.tex")
(bibtex-mode . "tex-insert.tex")
@@ -128,9 +129,9 @@ If this contains a %s, that will be replaced by the matching rule."
"\n\\end{document}")
(("/bin/.*[^/]\\'" . "Shell-Script mode magic number") .
- (lambda ()
- (if (eq major-mode (default-value 'major-mode))
- (sh-mode))))
+ ,(lambda ()
+ (if (eq major-mode (default-value 'major-mode))
+ (sh-mode))))
(ada-mode . ada-header)
@@ -171,7 +172,7 @@ If this contains a %s, that will be replaced by the matching rule."
'(setq v1 (let (modes)
(mapatoms (lambda (mode)
(let ((name (symbol-name mode)))
- (when (string-match "-mode$" name)
+ (when (string-match "-mode\\'" name)
(push name modes)))))
(sort modes 'string<)))
(completing-read "Local variables for mode: " v1 nil t)
@@ -210,7 +211,8 @@ If this contains a %s, that will be replaced by the matching rule."
"\n"))
((let ((minibuffer-help-form v2))
(completing-read "Keyword, C-h: " v1 nil t))
- str ", ") & -2 "
+ str ", ")
+ & -2 "
\;; This program is free software; you can redistribute it and/or modify
\;; it under the terms of the GNU General Public License as published by
diff --git a/lisp/bindings.el b/lisp/bindings.el
index 8ae8c3d60ef..1913f826004 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -1402,10 +1402,8 @@ if `inhibit-field-text-motion' is non-nil."
(define-key esc-map [?\C-\ ] 'mark-sexp)
(define-key esc-map "\C-d" 'down-list)
(define-key esc-map "\C-k" 'kill-sexp)
-;;; These are dangerous in various situations,
-;;; so let's not encourage anyone to use them.
-;;;(define-key global-map [C-M-delete] 'backward-kill-sexp)
-;;;(define-key global-map [C-M-backspace] 'backward-kill-sexp)
+(define-key global-map [C-M-delete] 'backward-kill-sexp)
+(define-key global-map [C-M-backspace] 'backward-kill-sexp)
(define-key esc-map [C-delete] 'backward-kill-sexp)
(define-key esc-map [C-backspace] 'backward-kill-sexp)
(define-key esc-map "\C-n" 'forward-list)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 80fb1cdfc78..31876c83a2f 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -246,11 +246,13 @@ functions have a binding in this keymap."
Bookmark functions update the value automatically.
You probably do NOT want to change the value yourself.
-The value is an alist with bookmarks of the form
+The value is an alist whose elements are of the form
(BOOKMARK-NAME . PARAM-ALIST)
-or the deprecated form (BOOKMARK-NAME PARAM-ALIST).
+or the deprecated form (BOOKMARK-NAME PARAM-ALIST). The alist is
+ordered from most recently created bookmark at the front to least
+recently created bookmark at the end.
BOOKMARK-NAME is the name you gave to the bookmark when creating it.
@@ -583,10 +585,10 @@ old one."
;; Modify using the new (NAME . ALIST) format.
(setcdr bm alist))
- ;; otherwise just cons it onto the front (either the bookmark
- ;; doesn't exist already, or there is no prefix arg. In either
- ;; case, we want the new bookmark consed onto the alist...)
-
+ ;; Otherwise just put it onto the front of the list. Either the
+ ;; bookmark doesn't exist already, or there is no prefix arg.
+ ;; In either case, we want the new bookmark on the front of the
+ ;; list, since the list is kept in reverse order of creation.
(push (cons stripped-name alist) bookmark-alist))
;; Added by db
@@ -1140,7 +1142,9 @@ it to the name of the bookmark currently being set, advancing
(defun bookmark-maybe-sort-alist ()
"Return `bookmark-alist' for display.
-If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist."
+If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist.
+Otherwise, just return `bookmark-alist', which by default is ordered
+from most recently created to least recently created bookmark."
(if bookmark-sort-flag
(sort (copy-alist bookmark-alist)
(lambda (x y) (string-lessp (car x) (car y))))
@@ -1728,6 +1732,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
"x" #'bookmark-bmenu-execute-deletions
"d" #'bookmark-bmenu-delete
"D" #'bookmark-bmenu-delete-all
+ "S-SPC" #'previous-line
"SPC" #'next-line
"DEL" #'bookmark-bmenu-backup-unmark
"u" #'bookmark-bmenu-unmark
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index ebdafb438e3..a7d13cff9a1 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -510,9 +510,13 @@ The time should be in either 24 hour format or am/pm format.
Optional argument WARNTIME is an integer (or string) giving the number
of minutes before the appointment at which to start warning.
The default is `appt-message-warning-time'."
- (interactive "sTime (hh:mm[am/pm]): \nsMessage: \n\
-sMinutes before the appointment to start warning: ")
- (unless (string-match appt-time-regexp time)
+ (interactive (list (let ((time (read-string "Time (hh:mm[am/pm]): ")))
+ (unless (string-match-p appt-time-regexp time)
+ (user-error "Unacceptable time-string"))
+ time)
+ (read-string "Message: ")
+ (read-string "Minutes before the appointment to start warning: ")))
+ (unless (string-match-p appt-time-regexp time)
(user-error "Unacceptable time-string"))
(and (stringp warntime)
(setq warntime (unless (string-equal warntime "")
diff --git a/lisp/color.el b/lisp/color.el
index 0fe663d97a7..fe629f4f988 100644
--- a/lisp/color.el
+++ b/lisp/color.el
@@ -403,7 +403,7 @@ See `color-desaturate-hsl'."
Given a color defined in terms of hue, saturation, and luminance
\(arguments H, S, and L), return a color that is PERCENT lighter.
Returns a list (HUE SATURATION LUMINANCE)."
- (list H S (color-clamp (+ L (/ percent 100.0)))))
+ (list H S (color-clamp (+ L (* L (/ percent 100.0))))))
(defun color-lighten-name (name percent)
"Make a color with a specified NAME lighter by PERCENT.
diff --git a/lisp/comint.el b/lisp/comint.el
index 4c82e74e4bc..56082f622a5 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -1515,6 +1515,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'."
#'comint-history-isearch-wrap)
(setq-local isearch-push-state-function
#'comint-history-isearch-push-state)
+ (setq-local isearch-lazy-count nil)
(add-hook 'isearch-mode-end-hook 'comint-history-isearch-end nil t)))
(defun comint-history-isearch-end ()
@@ -1526,6 +1527,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'."
(setq isearch-message-function nil)
(setq isearch-wrap-function nil)
(setq isearch-push-state-function nil)
+ (kill-local-variable 'isearch-lazy-count)
(remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t)
(unless isearch-suspended
(custom-reevaluate-setting 'comint-history-isearch)))
diff --git a/lisp/desktop.el b/lisp/desktop.el
index e7a368e21f5..7e3d66bdf1f 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -230,16 +230,26 @@ Zero or nil means disable auto-saving due to idleness."
(defcustom desktop-load-locked-desktop 'ask
"Specifies whether the desktop should be loaded if locked.
Possible values are:
- t -- load anyway.
- nil -- don't load.
- ask -- ask the user.
-If the value is nil, or `ask' and the user chooses not to load the desktop,
-the normal hook `desktop-not-loaded-hook' is run."
+ t -- load anyway.
+ nil -- don't load.
+ ask -- ask the user.
+ check-pid -- load if locking Emacs process is missing locally.
+
+If the value is nil, or `ask' and the user chooses not to load
+the desktop, the normal hook `desktop-not-loaded-hook' is run.
+
+If the value is `check-pid', load the desktop if the Emacs
+process that has locked it is not running on the local machine.
+This should not be used in circumstances where the locking Emacs
+might still be running on another machine. That could be the
+case if you have remotely mounted (NFS) paths in
+`desktop-dirname'."
:type
'(choice
(const :tag "Load anyway" t)
(const :tag "Don't load" nil)
- (const :tag "Ask the user" ask))
+ (const :tag "Ask the user" ask)
+ (const :tag "Load if no local process" check-pid))
:group 'desktop
:version "22.2")
@@ -662,6 +672,44 @@ DIRNAME omitted or nil means use `desktop-dirname'."
(integerp owner)))
owner)))
+(defun desktop--emacs-pid-running-p (pid)
+ "Return non-nil if an Emacs process whose ID is PID might still be running."
+ (when-let ((attr (process-attributes pid)))
+ (let ((proc-cmd (alist-get 'comm attr))
+ (my-cmd (file-name-nondirectory (car command-line-args)))
+ (case-fold-search t))
+ (or (equal proc-cmd my-cmd)
+ (and (eq system-type 'windows-nt)
+ (eq t (compare-strings proc-cmd
+ nil
+ (if (string-suffix-p ".exe" proc-cmd t)
+ -4)
+ my-cmd
+ nil
+ (if (string-suffix-p ".exe" my-cmd t)
+ -4))))
+ ;; We should err on the safe side here: if any of the
+ ;; executables is something like "emacs-nox" or "emacs-42.1"
+ ;; or "gemacs" or "xemacs", let's recognize them as well.
+ (and (string-match-p "emacs" proc-cmd)
+ (string-match-p "emacs" my-cmd))))))
+
+(defun desktop--load-locked-desktop-p (owner)
+ "Return t if a locked desktop should be loaded.
+OWNER is the pid in the lock file.
+The return value of this function depends on the value of
+`desktop-load-locked-desktop'."
+ (pcase desktop-load-locked-desktop
+ ('ask
+ (unless (daemonp)
+ (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\
+Using it may cause conflicts. Use it anyway? " owner))))
+ ('check-pid
+ (or (eq (emacs-pid) owner)
+ (not (desktop--emacs-pid-running-p owner))))
+ ('nil nil)
+ (_ t)))
+
(defun desktop-claim-lock (&optional dirname)
"Record this Emacs process as the owner of the desktop file in DIRNAME.
DIRNAME omitted or nil means use `desktop-dirname'."
@@ -1263,11 +1311,7 @@ It returns t if a desktop file was loaded, nil otherwise.
(desktop-save nil)
(desktop-autosave-was-enabled))
(if (and owner
- (memq desktop-load-locked-desktop '(nil ask))
- (or (null desktop-load-locked-desktop)
- (daemonp)
- (not (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\
-Using it may cause conflicts. Use it anyway? " owner)))))
+ (not (desktop--load-locked-desktop-p owner)))
(let ((default-directory desktop-dirname))
(setq desktop-dirname nil)
(run-hooks 'desktop-not-loaded-hook)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 56897826cbc..c49e4e91d83 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -796,6 +796,15 @@ offer a smarter default choice of shell command."
'read-shell-command prompt nil nil))))
;;;###autoload
+(defcustom dired-confirm-shell-command t
+ "Whether to prompt for confirmation for ‘dired-do-shell-command’.
+If non-nil, prompt for confirmation if the command contains potentially
+dangerous characters. If nil, never prompt for confirmation."
+ :type 'boolean
+ :group 'dired
+ :version "29.1")
+
+;;;###autoload
(defun dired-do-async-shell-command (command &optional arg file-list)
"Run a shell command COMMAND on the marked files asynchronously.
@@ -873,7 +882,9 @@ can be produced by `dired-get-marked-files', for example.
`dired-guess-shell-alist-default' and
`dired-guess-shell-alist-user' are consulted when the user is
-prompted for the shell command to use interactively."
+prompted for the shell command to use interactively.
+
+Also see the `dired-confirm-shell-command' variable."
;; Functions dired-run-shell-command and dired-shell-stuff-it do the
;; actual work and can be redefined for customization.
(interactive
@@ -891,6 +902,8 @@ prompted for the shell command to use interactively."
(ok (cond
((not (or on-each no-subst))
(error "You can not combine `*' and `?' substitution marks"))
+ ((not dired-confirm-shell-command)
+ t)
((setq confirmations (dired--need-confirm-positions command "*"))
(dired--no-subst-confirm confirmations command))
((setq confirmations (dired--need-confirm-positions command "?"))
@@ -3142,16 +3155,16 @@ a file name. Otherwise, it searches the whole buffer without restrictions."
(define-minor-mode dired-isearch-filenames-mode
"Toggle file names searching on or off.
-When on, Isearch skips matches outside file names using the predicate
-`dired-isearch-filter-filenames' that matches only at file names.
-When off, it uses the original predicate."
+When on, Isearch skips matches outside file names using the search function
+`dired-isearch-search-filenames' that matches only at file names.
+When off, it uses the default search function."
:lighter nil
(if dired-isearch-filenames-mode
- (add-function :before-while (local 'isearch-filter-predicate)
- #'dired-isearch-filter-filenames
+ (add-function :around (local 'isearch-search-fun-function)
+ #'dired-isearch-search-filenames
'((isearch-message-prefix . "filename ")))
- (remove-function (local 'isearch-filter-predicate)
- #'dired-isearch-filter-filenames))
+ (remove-function (local 'isearch-search-fun-function)
+ #'dired-isearch-search-filenames))
(when isearch-mode
(setq isearch-success t isearch-adjusted t)
(isearch-update)))
@@ -3175,12 +3188,46 @@ Intended to be added to `isearch-mode-hook'."
(unless isearch-suspended
(kill-local-variable 'dired-isearch-filenames)))
-(defun dired-isearch-filter-filenames (beg end)
- "Test whether some part of the current search match is inside a file name.
-This function returns non-nil if some part of the text between BEG and END
-is part of a file name (i.e., has the text property `dired-filename')."
- (text-property-not-all (min beg end) (max beg end)
- 'dired-filename nil))
+(defun dired-isearch-search-filenames (orig-fun)
+ "Return the function that searches inside file names.
+The returned function narrows the search to match the search string
+only as part of a file name enclosed by the text property `dired-filename'.
+It's intended to override the default search function."
+ (let ((search-fun (funcall orig-fun))
+ (property 'dired-filename))
+ (lambda (string &optional bound noerror count)
+ (let* ((old (point))
+ ;; Check if point is already on the property.
+ (beg (when (get-text-property
+ (if isearch-forward old (max (1- old) (point-min)))
+ property)
+ old))
+ end found)
+ ;; Otherwise, try to search for the next property.
+ (unless beg
+ (setq beg (if isearch-forward
+ (next-single-property-change old property)
+ (previous-single-property-change old property)))
+ (when beg (goto-char beg)))
+ ;; Non-nil `beg' means there are more properties.
+ (while (and beg (not found))
+ ;; Search for the end of the current property.
+ (setq end (if isearch-forward
+ (next-single-property-change beg property)
+ (previous-single-property-change beg property)))
+ (setq found (funcall
+ search-fun string (if bound (if isearch-forward
+ (min bound end)
+ (max bound end))
+ end)
+ noerror count))
+ (unless found
+ (setq beg (if isearch-forward
+ (next-single-property-change end property)
+ (previous-single-property-change end property)))
+ (when beg (goto-char beg))))
+ (unless found (goto-char old))
+ found))))
;;;###autoload
(defun dired-isearch-filenames ()
diff --git a/lisp/dired.el b/lisp/dired.el
index bca30189230..5accad8efd2 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -248,6 +248,28 @@ The target is used in the prompt for file copy, rename etc."
(other :tag "Try to guess" t))
:group 'dired)
+
+(defcustom dired-mouse-drag-files nil
+ "If non-nil, allow the mouse to drag files from inside a Dired buffer.
+Dragging the mouse and then releasing it over the window of
+another program will result in that program opening the file, or
+creating a copy of it. This feature is supported only on X
+Windows and Haiku.
+
+If the value is `link', then a symbolic link will be created to
+the file instead by the other program (usually a file manager)."
+ :set (lambda (option value)
+ (set-default option value)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (derived-mode-p 'dired-mode)
+ (revert-buffer nil t)))))
+ :type '(choice (const :tag "Don't allow dragging" nil)
+ (const :tag "Copy file to other window" t)
+ (const :tag "Create symbolic link to file" link))
+ :group 'dired
+ :version "29.1")
+
(defcustom dired-copy-preserve-time t
"If non-nil, Dired preserves the last-modified time in a file copy.
\(This works on only some systems.)"
@@ -1260,39 +1282,42 @@ The return value is the target column for the file names."
;; This differs from dired-buffers-for-dir in that it does not consider
;; subdirs of default-directory and searches for the first match only.
;; Also, the major mode must be MODE.
- (if (and (featurep 'dired-x)
- dired-find-subdir
- ;; Don't try to find a wildcard as a subdirectory.
- (string-equal dirname (file-name-directory dirname)))
- (let* ((cur-buf (current-buffer))
- (buffers (nreverse (dired-buffers-for-dir dirname)))
- (cur-buf-matches (and (memq cur-buf buffers)
- ;; Wildcards must match, too:
- (equal dired-directory dirname))))
- ;; We don't want to switch to the same buffer---
- (setq buffers (delq cur-buf buffers))
- (or (car (sort buffers #'dired-buffer-more-recently-used-p))
- ;; ---unless it's the only possibility:
- (and cur-buf-matches cur-buf)))
- ;; No dired-x, or dired-find-subdir nil.
- (setq dirname (expand-file-name dirname))
- (let (found (blist dired-buffers)) ; was (buffer-list)
- (or mode (setq mode 'dired-mode))
- (while blist
- (if (null (buffer-name (cdr (car blist))))
- (setq blist (cdr blist))
- (with-current-buffer (cdr (car blist))
- (if (and (eq major-mode mode)
- dired-directory ;; nil during find-alternate-file
- (equal dirname
- (expand-file-name
- (if (consp dired-directory)
- (car dired-directory)
- dired-directory))))
- (setq found (cdr (car blist))
- blist nil)
- (setq blist (cdr blist))))))
- found)))
+ ;; We bind `non-essential' in order to avoid hangs in remote buffers
+ ;; with a blocked connection. (Bug#54542)
+ (let ((non-essential t))
+ (if (and (featurep 'dired-x)
+ dired-find-subdir
+ ;; Don't try to find a wildcard as a subdirectory.
+ (string-equal dirname (file-name-directory dirname)))
+ (let* ((cur-buf (current-buffer))
+ (buffers (nreverse (dired-buffers-for-dir dirname)))
+ (cur-buf-matches (and (memq cur-buf buffers)
+ ;; Wildcards must match, too:
+ (equal dired-directory dirname))))
+ ;; We don't want to switch to the same buffer---
+ (setq buffers (delq cur-buf buffers))
+ (or (car (sort buffers #'dired-buffer-more-recently-used-p))
+ ;; ---unless it's the only possibility:
+ (and cur-buf-matches cur-buf)))
+ ;; No dired-x, or dired-find-subdir nil.
+ (setq dirname (expand-file-name dirname))
+ (let (found (blist dired-buffers)) ; was (buffer-list)
+ (or mode (setq mode 'dired-mode))
+ (while blist
+ (if (null (buffer-name (cdr (car blist))))
+ (setq blist (cdr blist))
+ (with-current-buffer (cdr (car blist))
+ (if (and (eq major-mode mode)
+ dired-directory ;; nil during find-alternate-file
+ (equal dirname
+ (expand-file-name
+ (if (consp dired-directory)
+ (car dired-directory)
+ dired-directory))))
+ (setq found (cdr (car blist))
+ blist nil)
+ (setq blist (cdr blist))))))
+ found))))
;;; Read in a new dired buffer
@@ -1674,6 +1699,83 @@ see `dired-use-ls-dired' for more details.")
beg))
beg))))
+(defvar dired-last-dragged-remote-file nil
+ "If non-nil, the name of a local copy of the last remote file that was dragged.
+It can't be removed immediately after the drag-and-drop operation
+completes, since there is no way to determine when the drop
+target has finished opening it. So instead, this file is removed
+when Emacs exits or the user drags another file.")
+
+(declare-function x-begin-drag "xfns.c")
+
+(defun dired-remove-last-dragged-local-file ()
+ "Remove the local copy of the last remote file to be dragged."
+ (when dired-last-dragged-remote-file
+ (unwind-protect
+ (delete-file dired-last-dragged-remote-file)
+ (setq dired-last-dragged-remote-file nil)))
+ (remove-hook 'kill-emacs-hook #'dired-remove-last-dragged-local-file))
+
+(defun dired-mouse-drag (event)
+ "Begin a drag-and-drop operation for the file at EVENT."
+ (interactive "e")
+ (when mark-active
+ (deactivate-mark))
+ (dired-remove-last-dragged-local-file)
+ (save-excursion
+ (with-selected-window (posn-window (event-end event))
+ (goto-char (posn-point (event-end event))))
+ (track-mouse
+ (let ((beginning-position (mouse-pixel-position))
+ new-event)
+ (catch 'track-again
+ (setq new-event (read-event))
+ (if (not (eq (event-basic-type new-event) 'mouse-movement))
+ (when (eq (event-basic-type new-event) 'mouse-1)
+ (push new-event unread-command-events))
+ (let ((current-position (mouse-pixel-position)))
+ ;; If the mouse didn't move far enough, don't
+ ;; inadvertently trigger a drag.
+ (when (and (eq (car current-position) (car beginning-position))
+ (ignore-errors
+ (and (> 3 (abs (- (cadr beginning-position)
+ (cadr current-position))))
+ (> 3 (abs (- (caddr beginning-position)
+ (caddr current-position)))))))
+ (throw 'track-again nil)))
+ ;; We can get an error if there's by some chance no file
+ ;; name at point.
+ (condition-case nil
+ (let ((filename (with-selected-window (posn-window
+ (event-end event))
+ (dired-file-name-at-point))))
+ (when filename
+ ;; In theory x-dnd-username combined with a proper
+ ;; file URI containing the hostname of the remote
+ ;; server could be used here instead of creating a
+ ;; local copy of the remote file, but no program
+ ;; actually implements file DND according to the
+ ;; spec.
+ (when (file-remote-p filename)
+ (setq filename (file-local-copy filename))
+ (setq dired-last-dragged-remote-file filename)
+ (add-hook 'kill-emacs-hook
+ #'dired-remove-last-dragged-local-file))
+ (gui-backend-set-selection 'XdndSelection filename)
+ (x-begin-drag '("text/uri-list" "text/x-dnd-username"
+ "FILE_NAME" "FILE" "HOST_NAME")
+ (if (eq 'dired-mouse-drag-files 'link)
+ 'XdndActionLink
+ 'XdndActionCopy)
+ nil nil t)))
+ (error (when (eq (event-basic-type new-event) 'mouse-1)
+ (push new-event unread-command-events))))))))))
+
+(defvar dired-mouse-drag-files-map (let ((keymap (make-sparse-keymap)))
+ (define-key keymap [down-mouse-1] #'dired-mouse-drag)
+ keymap)
+ "Keymap applied to file names when `dired-mouse-drag-files' is enabled.")
+
(defun dired-insert-set-properties (beg end)
"Add various text properties to the lines in the region, from BEG to END."
(save-excursion
@@ -1688,15 +1790,27 @@ see `dired-use-ls-dired' for more details.")
'invisible 'dired-hide-details-information))
(put-text-property (+ (line-beginning-position) 1) (1- (point))
'invisible 'dired-hide-details-detail)
+ (when (and dired-mouse-drag-files (fboundp 'x-begin-drag))
+ (put-text-property (point)
+ (save-excursion
+ (dired-move-to-end-of-filename)
+ (backward-char)
+ (point))
+ 'keymap
+ dired-mouse-drag-files-map))
(add-text-properties
(point)
(progn
(dired-move-to-end-of-filename)
(point))
- '(mouse-face
+ `(mouse-face
highlight
dired-filename t
- help-echo "mouse-2: visit this file in other window"))
+ help-echo ,(if (and dired-mouse-drag-files
+ (fboundp 'x-begin-drag))
+ "down-mouse-1: drag this file to another program
+mouse-2: visit this file in other window"
+ "mouse-2: visit this file in other window")))
(when (< (+ (point) 4) (line-end-position))
(put-text-property (+ (point) 4) (line-end-position)
'invisible 'dired-hide-details-link))))
diff --git a/lisp/dnd.el b/lisp/dnd.el
index 97e81e9bf11..4f71edf1aa1 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -42,8 +42,7 @@
`((,(purecopy "^file:///") . dnd-open-local-file) ; XDND format.
(,(purecopy "^file://") . dnd-open-file) ; URL with host
(,(purecopy "^file:") . dnd-open-local-file) ; Old KDE, Motif, Sun
- (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file)
- )
+ (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file))
"The functions to call for different protocols when a drop is made.
This variable is used by `dnd-handle-one-url' and `dnd-handle-file-name'.
@@ -57,7 +56,8 @@ If no match is found, the URL is inserted as text by calling `dnd-insert-text'.
The function shall return the action done (move, copy, link or private)
if some action was made, or nil if the URL is ignored."
:version "22.1"
- :type '(repeat (cons (regexp) (function))))
+ :type '(repeat (cons (regexp) (function)))
+ :group 'dnd)
(defcustom dnd-open-remote-file-function
@@ -73,17 +73,68 @@ Predefined functions are `dnd-open-local-file' and `dnd-open-remote-url'.
is the default on MS-Windows. `dnd-open-remote-url' uses `url-handler-mode'
and is the default except for MS-Windows."
:version "22.1"
- :type 'function)
+ :type 'function
+ :group 'dnd)
(defcustom dnd-open-file-other-window nil
"If non-nil, always use `find-file-other-window' to open dropped files."
:version "22.1"
- :type 'boolean)
-
+ :type 'boolean
+ :group 'dnd)
+
+(defcustom dnd-scroll-margin nil
+ "The scroll margin inside a window underneath the cursor during drag-and-drop.
+If the mouse moves this many lines close to the top or bottom of
+a window while dragging text, then that window will be scrolled
+down and up respectively."
+ :type '(choice (const :tag "Don't scroll during mouse movement")
+ (integer :tag "This many lines from window top or bottom"))
+ :version "29.1"
+ :group 'dnd)
+
+(defcustom dnd-indicate-insertion-point nil
+ "Whether or not point should follow the position of the mouse.
+If non-nil, the point of the window underneath the mouse will be
+adjusted to reflect where any text will be inserted upon drop
+when the mouse moves while receiving a drop from another
+program."
+ :type 'boolean
+ :version "29.1"
+ :group 'dnd)
;; Functions
+(defun dnd-handle-movement (posn)
+ "Handle mouse movement to POSN when receiving a drop from another program."
+ (when (windowp (posn-window posn))
+ (with-selected-window (posn-window posn)
+ (when dnd-scroll-margin
+ (ignore-errors
+ (let* ((row (cdr (posn-col-row posn)))
+ (window (when (windowp (posn-window posn))
+ (posn-window posn)))
+ (text-height (window-text-height window))
+ ;; Make sure it's possible to scroll both up
+ ;; and down if the margin is too large for the
+ ;; window.
+ (margin (min (/ text-height 3) dnd-scroll-margin)))
+ ;; At 2 lines, the window becomes too small for any
+ ;; meaningful scrolling.
+ (unless (<= text-height 2)
+ (cond
+ ;; Inside the bottom scroll margin, scroll up.
+ ((> row (- text-height margin))
+ (with-selected-window window
+ (scroll-up 1)))
+ ;; Inside the top scroll margin, scroll down.
+ ((< row margin)
+ (with-selected-window window
+ (scroll-down 1))))))))
+ (when dnd-indicate-insertion-point
+ (ignore-errors
+ (goto-char (posn-point posn)))))))
+
(defun dnd-handle-one-url (window action url)
"Handle one dropped url by calling the appropriate handler.
The handler is first located by looking at `dnd-protocol-alist'.
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 2561994f7bd..179fea786d0 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -99,8 +99,7 @@ With a prefix argument, format the macro in a more concise way."
(when keys
(let ((cmd (if (arrayp keys) (key-binding keys) keys))
(cmd-noremap (when (arrayp keys) (key-binding keys nil t)))
- (mac nil) (mac-counter nil) (mac-format nil)
- kmacro)
+ (mac nil) (mac-counter nil) (mac-format nil))
(cond (store-hook
(setq mac keys)
(setq cmd nil))
@@ -131,10 +130,10 @@ With a prefix argument, format the macro in a more concise way."
(t
(setq mac cmd)
(setq cmd nil)))
- (when (setq kmacro (kmacro-extract-lambda mac))
- (setq mac (car kmacro)
- mac-counter (nth 1 kmacro)
- mac-format (nth 2 kmacro)))
+ (when (kmacro-p mac)
+ (setq mac (kmacro--keys mac)
+ mac-counter (kmacro--counter mac)
+ mac-format (kmacro--format mac)))
(unless (arrayp mac)
(error "Key sequence %s is not a keyboard macro"
(key-description keys)))
@@ -260,7 +259,7 @@ or nil, use a compact 80-column format."
(push key keys)
(let ((b (key-binding key)))
(and b (commandp b) (not (arrayp b))
- (not (kmacro-extract-lambda b))
+ (not (kmacro-p b))
(or (not (fboundp b))
(not (or (arrayp (symbol-function b))
(get b 'kmacro))))
@@ -313,10 +312,7 @@ or nil, use a compact 80-column format."
(when cmd
(if (= (length mac) 0)
(fmakunbound cmd)
- (fset cmd
- (if (and mac-counter mac-format)
- (kmacro-lambda-form mac mac-counter mac-format)
- mac))))
+ (fset cmd (kmacro mac mac-counter mac-format))))
(if no-keys
(when cmd
(cl-loop for key in (where-is-internal cmd '(keymap)) do
@@ -327,10 +323,8 @@ or nil, use a compact 80-column format."
(cl-loop for key in keys do
(global-set-key key
(or cmd
- (if (and mac-counter mac-format)
- (kmacro-lambda-form
- mac mac-counter mac-format)
- mac))))))))))
+ (kmacro mac mac-counter
+ mac-format))))))))))
(kill-buffer buf)
(when (buffer-name obuf)
(switch-to-buffer obuf))
@@ -645,9 +639,9 @@ This function assumes that the events can be stored in a string."
;;; Parsing a human-readable keyboard macro.
-(defun edmacro-parse-keys (string &optional need-vector)
+(defun edmacro-parse-keys (string &optional _need-vector)
(let ((result (kbd string)))
- (if (and need-vector (stringp result))
+ (if (stringp result)
(seq-into result 'vector)
result)))
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index d0bf342b842..1e4b2c14a01 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1108,6 +1108,9 @@ directory or directories specified."
;; Files with no autoload cookies or whose autoloads go to other
;; files because of file-local autoload-generated-file settings.
(no-autoloads nil)
+ ;; Ensure that we don't do odd things when putting the doc
+ ;; strings into the autoloads file.
+ (left-margin 0)
(autoload-modified-buffers nil)
(output-time
(and (file-exists-p output-file)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 0a79bf9b797..39bb6224595 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1049,6 +1049,14 @@ See Info node `(elisp) Integer Basics'."
form ; No improvement.
(cons 'concat (nreverse newargs)))))
+(defun byte-optimize-string-greaterp (form)
+ ;; Rewrite in terms of `string-lessp' which has its own bytecode.
+ (pcase (cdr form)
+ (`(,a ,b) (let ((arg1 (make-symbol "arg1")))
+ `(let ((,arg1 ,a))
+ (string-lessp ,b ,arg1))))
+ (_ form)))
+
(put 'identity 'byte-optimizer #'byte-optimize-identity)
(put 'memq 'byte-optimizer #'byte-optimize-memq)
(put 'memql 'byte-optimizer #'byte-optimize-member)
@@ -1072,6 +1080,9 @@ See Info node `(elisp) Integer Basics'."
(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate)
(put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate)
+(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp)
+(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp)
+
(put 'concat 'byte-optimizer #'byte-optimize-concat)
;; I'm not convinced that this is necessary. Doesn't the optimizer loop
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index c680437f324..c39d931517e 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -3924,7 +3924,7 @@ discarding."
docstring-exp)) ;Otherwise, we don't need a closure.
(cl-assert (byte-code-function-p fun))
(byte-compile-form
- (if (or (not docstring-exp) (stringp docstring-exp))
+ (if (macroexp-const-p docstring-exp)
;; Use symbols V0, V1 ... as placeholders for closure variables:
;; they should be short (to save space in the .elc file), yet
;; distinct when disassembled.
@@ -3940,7 +3940,7 @@ discarding."
(vconcat dummy-vars (aref fun 2))
(aref fun 3)
(if docstring-exp
- (cons docstring-exp (cdr opt-args))
+ (cons (eval docstring-exp t) (cdr opt-args))
opt-args))))
`(make-closure ,proto-fun ,@env))
;; Nontrivial doc string expression: create a bytecode object
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index c16619bc45d..be4fea7be14 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -201,7 +201,10 @@ Returns a form where all lambdas don't have any free variables."
(i 0)
(new-env ()))
;; Build the "formal and actual envs" for the closure-converted function.
- (dolist (fv fvs)
+ ;; Hack for OClosure: `nreverse' here intends to put the captured vars
+ ;; in the closure such that the first one is the one that is bound
+ ;; most closely.
+ (dolist (fv (nreverse fvs))
(let ((exp (or (cdr (assq fv env)) fv)))
(pcase exp
;; If `fv' is a variable that's wrapped in a cons-cell,
@@ -240,7 +243,7 @@ Returns a form where all lambdas don't have any free variables."
;; this case better, we'd need to traverse the tree one more time to
;; collect this data, and I think that it's not worth it.
(mapcar (lambda (mapping)
- (if (not (eq (cadr mapping) 'apply-partially))
+ (if (not (eq (cadr mapping) #'apply-partially))
mapping
(cl-assert (eq (car mapping) (nth 2 mapping)))
`(,(car mapping)
@@ -449,6 +452,9 @@ places where they originally did not directly appear."
(let ((var-def (cconv--lifted-arg var env))
(closedsym (make-symbol (format "closed-%s" var))))
(setq new-env (cconv--remap-llv new-env var closedsym))
+ ;; FIXME: `closedsym' doesn't need to be added to `extend'
+ ;; but adding it makes it easier to write the assertion at
+ ;; the beginning of this function.
(setq new-extend (cons closedsym (remq var new-extend)))
(push `(,closedsym ,var-def) binders-new)))
@@ -604,6 +610,14 @@ places where they originally did not directly appear."
(`(declare . ,_) form) ;The args don't contain code.
+ (`(oclosure--fix-type (ignore . ,vars) ,exp)
+ (dolist (var vars)
+ (let ((x (assq var env)))
+ (pcase (cdr x)
+ (`(car-safe . ,_) (error "Slot %S should not be mutated" var))
+ (_ (cl-assert (null (cdr x)))))))
+ (cconv-convert exp env extend))
+
(`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and,
;; if, catch, progn, prog1, while, until
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 7b11c0c8159..179310c145b 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -144,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
(cl-defstruct (cl--generic-method
(:constructor nil)
(:constructor cl--generic-make-method
- (specializers qualifiers uses-cnm function))
+ (specializers qualifiers call-con function))
(:predicate nil))
(specializers nil :read-only t :type list)
(qualifiers nil :read-only t :type (list-of atom))
- ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument
- ;; holding the next-method.
- (uses-cnm nil :read-only t :type boolean)
+ ;; CALL-CON indicates the calling convention expected by FUNCTION:
+ ;; - nil: FUNCTION is just a normal function with no extra arguments for
+ ;; `call-next-method' or `next-method-p' (which it hence can't use).
+ ;; - `curried': FUNCTION is a curried function that first takes the
+ ;; "next combined method" and return the resulting combined method.
+ ;; It can distinguish `next-method-p' by checking if that next method
+ ;; is `cl--generic-isnot-nnm-p'.
+ ;; - t: FUNCTION takes the `call-next-method' function as its first (extra)
+ ;; argument.
+ (call-con nil :read-only t :type symbol)
(function nil :read-only t :type function))
(cl-defstruct (cl--generic
@@ -301,8 +308,10 @@ DEFAULT-BODY, if present, is used as the body of a default method.
`(help-add-fundoc-usage ,doc ',args)
(help-add-fundoc-usage doc args)))
:autoload-end
- ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
- (nreverse methods)))
+ ,(when methods
+ `(with-suppressed-warnings ((obsolete ,name))
+ ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
+ (nreverse methods)))))
,@(mapcar (lambda (declaration)
(let ((f (cdr (assq (car declaration)
defun-declarations-alist))))
@@ -392,14 +401,16 @@ the specializer used will be the one returned by BODY."
. ,(lambda () spec-args))
macroexpand-all-environment)))
(require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
- (when (assq 'interactive (cadr fun))
+ (when (assq 'interactive body)
(message "Interactive forms not supported in generic functions: %S"
- (assq 'interactive (cadr fun))))
+ (assq 'interactive body)))
;; First macroexpand away the cl-function stuff (e.g. &key and
;; destructuring args, `declare' and whatnot).
(pcase (macroexpand fun macroenv)
(`#'(lambda ,args . ,body)
(let* ((parsed-body (macroexp-parse-body body))
+ (nm (make-symbol "cl--nm"))
+ (arglist (make-symbol "cl--args"))
(cnm (make-symbol "cl--cnm"))
(nmp (make-symbol "cl--nmp"))
(nbody (macroexpand-all
@@ -412,15 +423,49 @@ the specializer used will be the one returned by BODY."
;; is used.
;; FIXME: Also, optimize the case where call-next-method is
;; only called with explicit arguments.
- (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)))
- (cons (not (not uses-cnm))
- `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
- ,@(car parsed-body)
- ,(if (not (assq nmp uses-cnm))
- nbody
- `(let ((,nmp (lambda ()
- (cl--generic-isnot-nnm-p ,cnm))))
- ,nbody))))))
+ (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))
+ (λ-lift (mapcar #'car uses-cnm)))
+ (if (not uses-cnm)
+ (cons nil
+ `#'(lambda (,@args)
+ ,@(car parsed-body)
+ ,nbody))
+ (cons 'curried
+ `#'(lambda (,nm) ;Called when constructing the effective method.
+ (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm)
+ #'always #'ignore)))
+ ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))'
+ ;; dance is needed because we need to get the original
+ ;; args as a list when `cl-call-next-method' is
+ ;; called with no arguments. It's important to
+ ;; capture it as a list since it needs to distinguish
+ ;; the nil case from the absent case in optional
+ ;; arguments and it needs to properly remember the
+ ;; original value if `nbody' mutates some of its
+ ;; formal args.
+ ;; FIXME: This `(λ (&rest ,arglist)' could be skipped
+ ;; when we know `cnm' is always called with args, and
+ ;; it could be implemented more efficiently if `cnm'
+ ;; is always called directly and there are no
+ ;; `&optional' args.
+ (lambda (&rest ,arglist)
+ ,@(let* ((prebody (car parsed-body))
+ (ds (if (stringp (car prebody))
+ prebody
+ (setq prebody (cons nil prebody))))
+ (usage (help-split-fundoc (car ds) nil)))
+ (unless usage
+ (setcar ds (help-add-fundoc-usage (car ds)
+ args)))
+ prebody)
+ (let ((,cnm (lambda (&rest args)
+ (apply ,nm (or args ,arglist)))))
+ ;; This `apply+lambda' basically parses
+ ;; `arglist' according to `args'.
+ ;; A destructuring-bind would do the trick
+ ;; as well when/if it's more efficient.
+ (apply (lambda (,@λ-lift ,@args) ,nbody)
+ ,@λ-lift ,arglist)))))))))
(f (error "Unexpected macroexpansion result: %S" f))))))
(put 'cl-defmethod 'function-documentation
@@ -509,8 +554,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
- (let ((qualifiers nil)
- (orig-name name))
+ (let ((qualifiers nil))
(while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
@@ -518,23 +562,18 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(require 'gv)
(declare-function gv-setter "gv" (name))
(setq name (gv-setter (cadr name))))
- (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
+ (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body)))
`(progn
- ,(and (get name 'byte-obsolete-info)
- (or (not (fboundp 'byte-compile-warning-enabled-p))
- (byte-compile-warning-enabled-p 'obsolete name))
- (let* ((obsolete (get name 'byte-obsolete-info)))
- (macroexp-warn-and-return
- (macroexp--obsolete-warning name obsolete "generic function")
- nil nil nil orig-name)))
;; You could argue that `defmethod' modifies rather than defines the
;; function, so warnings like "not known to be defined" are fair game.
;; But in practice, it's common to use `cl-defmethod'
;; without a previous `cl-defgeneric'.
;; The ",'" is a no-op that pacifies check-declare.
(,'declare-function ,name "")
- (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
- ,uses-cnm ,fun)))))
+ ;; We use #' to quote `name' so as to trigger an
+ ;; obsolescence warning when applicable.
+ (cl-generic-define-method #',name ',(nreverse qualifiers) ',args
+ ',call-con ,fun)))))
(defun cl--generic-member-method (specializers qualifiers methods)
(while
@@ -552,7 +591,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
`(,name ,qualifiers . ,specializers))
;;;###autoload
-(defun cl-generic-define-method (name qualifiers args uses-cnm function)
+(defun cl-generic-define-method (name qualifiers args call-con function)
(pcase-let*
((generic (cl-generic-ensure-function name))
(`(,spec-args . ,_) (cl--generic-split-args args))
@@ -561,7 +600,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
spec-arg (cdr spec-arg)))
spec-args))
(method (cl--generic-make-method
- specializers qualifiers uses-cnm function))
+ specializers qualifiers call-con function))
(mt (cl--generic-method-table generic))
(me (cl--generic-member-method specializers qualifiers mt))
(dispatches (cl--generic-dispatches generic))
@@ -614,6 +653,14 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(defvar cl--generic-dispatchers (make-hash-table :test #'equal))
+(defvar cl--generic-compiler
+ ;; Don't byte-compile the dispatchers if cl-generic itself is not
+ ;; compiled. Otherwise the byte-compiler and all the code on
+ ;; which it depends needs to be usable before cl-generic is loaded,
+ ;; which imposes a significant burden on the bootstrap.
+ (if (consp (lambda (x) (+ x 1)))
+ (lambda (exp) (eval exp t)) #'byte-compile))
+
(defun cl--generic-get-dispatcher (dispatch)
(with-memoization
;; We need `copy-sequence` here because this `dispatch' object might be
@@ -658,7 +705,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
;; FIXME: For generic functions with a single method (or with 2 methods,
;; one of which always matches), using a tagcode + hash-table is
;; overkill: better just use a `cl-typep' test.
- (byte-compile
+ (funcall
+ cl--generic-compiler
`(lambda (generic dispatches-left methods)
;; FIXME: We should find a way to expand `with-memoize' once
;; and forall so we don't need `subr-x' when we get here.
@@ -729,29 +777,38 @@ for all those different tags in the method-cache.")
(list (cl--generic-name generic)))
f))))
-(defun cl--generic-no-next-method-function (generic method)
- (lambda (&rest args)
- (apply #'cl-no-next-method generic method args)))
+(oclosure-define (cl--generic-nnm)
+ "Special type for `call-next-method's that just call `no-next-method'.")
(defun cl-generic-call-method (generic method &optional fun)
"Return a function that calls METHOD.
FUN is the function that should be called when METHOD calls
`call-next-method'."
- (if (not (cl--generic-method-uses-cnm method))
- (cl--generic-method-function method)
- (let ((met-fun (cl--generic-method-function method))
- (next (or fun (cl--generic-no-next-method-function
- generic method))))
- (lambda (&rest args)
- (apply met-fun
- ;; FIXME: This sucks: passing just `next' would
- ;; be a lot more efficient than the lambda+apply
- ;; quasi-η, but we need this to implement the
- ;; "if call-next-method is called with no
- ;; arguments, then use the previous arguments".
- (lambda (&rest cnm-args)
- (apply next (or cnm-args args)))
- args)))))
+ (let ((met-fun (cl--generic-method-function method)))
+ (pcase (cl--generic-method-call-con method)
+ ('nil met-fun)
+ ('curried
+ (funcall met-fun (or fun
+ (oclosure-lambda (cl--generic-nnm) (&rest args)
+ (apply #'cl-no-next-method generic method
+ args)))))
+ ;; FIXME: backward compatibility with old convention for `.elc' files
+ ;; compiled before the `curried' convention.
+ (_
+ (lambda (&rest args)
+ (apply met-fun
+ (if fun
+ ;; FIXME: This sucks: passing just `next' would
+ ;; be a lot more efficient than the lambda+apply
+ ;; quasi-η, but we need this to implement the
+ ;; "if call-next-method is called with no
+ ;; arguments, then use the previous arguments".
+ (lambda (&rest cnm-args)
+ (apply fun (or cnm-args args)))
+ (oclosure-lambda (cl--generic-nnm) (&rest cnm-args)
+ (apply #'cl-no-next-method generic method
+ (or cnm-args args))))
+ args))))))
;; Standard CLOS name.
(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
@@ -886,11 +943,20 @@ those methods.")
(setq arg-or-context `(&context . ,arg-or-context)))
(unless (fboundp 'cl--generic-get-dispatcher)
(require 'cl-generic))
- (let ((fun (cl--generic-get-dispatcher
- `(,arg-or-context
- ,@(apply #'append
- (mapcar #'cl-generic-generalizers specializers))
- ,cl--generic-t-generalizer))))
+ (let ((fun
+ ;; Let-bind cl--generic-dispatchers so we *re*compute the function
+ ;; from scratch, since the one in the cache may be non-compiled!
+ (let ((cl--generic-dispatchers (make-hash-table))
+ ;; When compiling `cl-generic' during bootstrap, make sure
+ ;; we prefill with compiled dispatchers even though the loaded
+ ;; `cl-generic' is still interpreted.
+ (cl--generic-compiler
+ (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler)))
+ (cl--generic-get-dispatcher
+ `(,arg-or-context
+ ,@(apply #'append
+ (mapcar #'cl-generic-generalizers specializers))
+ ,cl--generic-t-generalizer)))))
;; Recompute dispatch at run-time, since the generalizers may be slightly
;; different (e.g. byte-compiled rather than interpreted).
;; FIXME: There is a risk that the run-time generalizer is not equivalent
@@ -908,36 +974,9 @@ those methods.")
"Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
(cl--generic-standard-method-combination generic methods))
-(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
-(defconst cl--generic-cnm-sample
- (funcall (cl--generic-build-combined-method
- nil (list (cl--generic-make-method () () t #'identity)))))
-
(defun cl--generic-isnot-nnm-p (cnm)
"Return non-nil if CNM is the function that calls `cl-no-next-method'."
- ;; ¡Big Gross Ugly Hack!
- ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
- ;; it, and some packages use it, so we need to support it.
- (catch 'found
- (cl-assert (function-equal cnm cl--generic-cnm-sample))
- (if (byte-code-function-p cnm)
- (let ((cnm-constants (aref cnm 2))
- (sample-constants (aref cl--generic-cnm-sample 2)))
- (dotimes (i (length sample-constants))
- (when (function-equal (aref sample-constants i)
- cl--generic-nnm-sample)
- (throw 'found
- (not (function-equal (aref cnm-constants i)
- cl--generic-nnm-sample))))))
- (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
- (let ((cnm-env (cadr cnm)))
- (dolist (vb (cadr cl--generic-cnm-sample))
- (when (function-equal (cdr vb) cl--generic-nnm-sample)
- (throw 'found
- (not (function-equal (cdar cnm-env)
- cl--generic-nnm-sample))))
- (setq cnm-env (cdr cnm-env)))))
- (error "Haven't found no-next-method-sample in cnm-sample")))
+ (not (eq (oclosure-type cnm) 'cl--generic-nnm)))
;;; Define some pre-defined generic functions, used internally.
@@ -1013,9 +1052,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(defun cl--generic-method-info (method)
(let* ((specializers (cl--generic-method-specializers method))
(qualifiers (cl--generic-method-qualifiers method))
- (uses-cnm (cl--generic-method-uses-cnm method))
+ (call-con (cl--generic-method-call-con method))
(function (cl--generic-method-function method))
- (args (help-function-arglist function 'names))
+ (args (help-function-arglist (if (not (eq call-con 'curried))
+ function
+ (funcall function #'ignore))
+ 'names))
(docstring (documentation function))
(qual-string
(if (null qualifiers) ""
@@ -1026,7 +1068,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring))))
(combined-args ()))
- (if uses-cnm (setq args (cdr args)))
+ (if (eq t call-con) (setq args (cdr args)))
(dolist (specializer specializers)
(let ((arg (if (eq '&rest (car args))
(intern (format "arg%d" (length combined-args)))
@@ -1054,7 +1096,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(dolist (method (cl--generic-method-table generic))
(let* ((info (cl--generic-method-info method)))
;; FIXME: Add hyperlinks for the types as well.
- (insert (format "%s%S" (nth 0 info) (nth 1 info)))
+ (let ((print-quoted nil))
+ (if (length> (nth 0 info) 0)
+ (insert (format "%s%S" (nth 0 info) (nth 1 info)))
+ ;; Make the non-":extra" bits look more like `C-h f'
+ ;; output.
+ (insert (format "%S" (cons function (nth 1 info))))))
(let* ((met-name (cl--generic-load-hist-format
function
(cl--generic-method-qualifiers method)
@@ -1082,7 +1129,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(let ((sclass (cl--find-class specializer))
(tclass (cl--find-class type)))
(when (and sclass tclass)
- (member specializer (cl--generic-class-parents tclass))))))
+ (member specializer (cl--class-allparents tclass))))))
(setq applies t)))
applies))
@@ -1211,22 +1258,11 @@ These match if the argument is `eql' to VAL."
;; Use exactly the same code as for `typeof'.
`(if ,name (type-of ,name) 'null))
-(defun cl--generic-class-parents (class)
- (let ((parents ())
- (classes (list class)))
- ;; BFS precedence. FIXME: Use a topological sort.
- (while (let ((class (pop classes)))
- (cl-pushnew (cl--class-name class) parents)
- (setq classes
- (append classes
- (cl--class-parents class)))))
- (nreverse parents)))
-
(defun cl--generic-struct-specializers (tag &rest _)
(and (symbolp tag)
(let ((class (get tag 'cl--class)))
(when (cl-typep class 'cl-structure-class)
- (cl--generic-class-parents class)))))
+ (cl--class-allparents class)))))
(cl-generic-define-generalizer cl--generic-struct-generalizer
50 #'cl--generic-struct-tag
@@ -1309,6 +1345,42 @@ Used internally for the (major-mode MODE) context specializers."
(progn (cl-assert (null modes)) mode)
`(derived-mode ,mode . ,modes))))
+;;; Dispatch on OClosure type
+
+;; It would make sense to put this into `oclosure.el' except that when
+;; `oclosure.el' is loaded `cl-defmethod' is not available yet.
+
+(defun cl--generic-oclosure-tag (name &rest _)
+ `(oclosure-type ,name))
+
+(defun cl-generic--oclosure-specializers (tag &rest _)
+ (and (symbolp tag)
+ (let ((class (cl--find-class tag)))
+ (when (cl-typep class 'oclosure--class)
+ (oclosure--class-allparents class)))))
+
+(cl-generic-define-generalizer cl-generic--oclosure-generalizer
+ ;; Give slightly higher priority than the struct specializer, so that
+ ;; for a generic function with methods dispatching structs and on OClosures,
+ ;; we first try `oclosure-type' before `type-of' since `type-of' will return
+ ;; non-nil for an OClosure as well.
+ 51 #'cl--generic-oclosure-tag
+ #'cl-generic--oclosure-specializers)
+
+(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type)
+ "Support for dispatch on types defined by `oclosure-define'."
+ (or
+ (when (symbolp type)
+ ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
+ ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
+ ;; take place without requiring cl-lib.
+ (let ((class (cl--find-class type)))
+ (and (cl-typep class 'oclosure--class)
+ (list cl-generic--oclosure-generalizer))))
+ (cl-call-next-method)))
+
+(cl--generic-prefill-dispatchers 0 oclosure)
+
;;; Support for unloading.
(cl-defmethod loadhist-unload-element ((x (head cl-defmethod)))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 0d0b5b51587..364b5120a0a 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2430,6 +2430,57 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(unless advised
(advice-remove 'macroexpand #'cl--sm-macroexpand)))))
+;;;###autoload
+(defmacro cl-with-gensyms (names &rest body)
+ "Bind each of NAMES to an uninterned symbol and evaluate BODY."
+ (declare (debug (sexp body)) (indent 1))
+ `(let ,(cl-loop for name in names collect
+ `(,name (gensym (symbol-name ',name))))
+ ,@body))
+
+;;;###autoload
+(defmacro cl-once-only (names &rest body)
+ "Generate code to evaluate each of NAMES just once in BODY.
+
+This macro helps with writing other macros. Each of names is
+either (NAME FORM) or NAME, which latter means (NAME NAME).
+During macroexpansion, each NAME is bound to an uninterned
+symbol. The expansion evaluates each FORM and binds it to the
+corresponding uninterned symbol.
+
+For example, consider this macro:
+
+ (defmacro my-cons (x)
+ (cl-once-only (x)
+ \\=`(cons ,x ,x)))
+
+The call (my-cons (pop y)) will expand to something like this:
+
+ (let ((g1 (pop y)))
+ (cons g1 g1))
+
+The use of `cl-once-only' ensures that the pop is performed only
+once, as intended.
+
+See also `macroexp-let2'."
+ (declare (debug (sexp body)) (indent 1))
+ (setq names (mapcar #'ensure-list names))
+ (let ((our-gensyms (cl-loop for _ in names collect (gensym))))
+ ;; During macroexpansion, obtain a gensym for each NAME.
+ `(let ,(cl-loop for sym in our-gensyms collect `(,sym (gensym)))
+ ;; Evaluate each FORM and bind to the corresponding gensym.
+ ;;
+ ;; We require this explicit call to `list' rather than using
+ ;; (,,@(cl-loop ...)) due to a limitation of Elisp's backquote.
+ `(let ,(list
+ ,@(cl-loop for name in names for gensym in our-gensyms
+ for to-eval = (or (cadr name) (car name))
+ collect ``(,,gensym ,,to-eval)))
+ ;; During macroexpansion, bind each NAME to its gensym.
+ ,(let ,(cl-loop for name in names for gensym in our-gensyms
+ collect `(,(car name) ,gensym))
+ ,@body)))))
+
;;; Multiple values.
;;;###autoload
@@ -3279,8 +3330,9 @@ the form NAME which is a shorthand for (NAME NAME)."
(funcall orig pred1
(cl--defstruct-predicate t2))))
(funcall orig pred1 pred2))))
-(advice-add 'pcase--mutually-exclusive-p
- :around #'cl--pcase-mutually-exclusive-p)
+(when (fboundp 'advice-add) ;Not available during bootstrap.
+ (advice-add 'pcase--mutually-exclusive-p
+ :around #'cl--pcase-mutually-exclusive-p))
(defun cl-struct-sequence-type (struct-type)
@@ -3624,7 +3676,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
(define-inline cl-struct-slot-value (struct-type slot-name inst)
"Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
-STRUCT and SLOT-NAME are symbols. INST is a structure instance."
+STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance."
(declare (side-effect-free t))
(inline-letevals (struct-type slot-name inst)
(inline-quote
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 6aa45526d84..93713f506d2 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -305,6 +305,17 @@ supertypes from the most specific to least specific.")
(cl-assert (cl--class-p (cl--find-class 'cl-structure-class)))
(cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
+(defun cl--class-allparents (class)
+ (let ((parents ())
+ (classes (list class)))
+ ;; BFS precedence. FIXME: Use a topological sort.
+ (while (let ((class (pop classes)))
+ (cl-pushnew (cl--class-name class) parents)
+ (setq classes
+ (append classes
+ (cl--class-parents class)))))
+ (nreverse parents)))
+
;; Make sure functions defined with cl-defsubst can be inlined even in
;; packages which do not require CL. We don't put an autoload cookie
;; directly on that function, since those cookies only go to cl-loaddefs.
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 122638077ce..00efedd71f3 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -898,6 +898,8 @@ non local exit (ends with an `unreachable' insn)."))
:documentation "Doc string.")
(int-spec nil :type list
:documentation "Interactive form.")
+ (command-modes nil :type list
+ :documentation "Command modes.")
(lap () :type list
:documentation "LAP assembly representation.")
(ssa-status nil :type symbol
@@ -1243,6 +1245,7 @@ clashes."
:c-name c-name
:doc (documentation f t)
:int-spec (interactive-form f)
+ :command-modes (command-modes f)
:speed (comp-spill-speed function-name)
:pure (comp-spill-decl-spec function-name
'pure))))
@@ -1282,10 +1285,12 @@ clashes."
(make-comp-func-l :c-name c-name
:doc (documentation form t)
:int-spec (interactive-form form)
+ :command-modes (command-modes form)
:speed (comp-ctxt-speed comp-ctxt))
(make-comp-func-d :c-name c-name
:doc (documentation form t)
:int-spec (interactive-form form)
+ :command-modes (command-modes form)
:speed (comp-ctxt-speed comp-ctxt)))))
(let ((lap (byte-to-native-lambda-lap
(gethash (aref byte-code 1)
@@ -1327,6 +1332,7 @@ clashes."
(comp-func-byte-func func) byte-func
(comp-func-doc func) (documentation byte-func t)
(comp-func-int-spec func) (interactive-form byte-func)
+ (comp-func-command-modes func) (command-modes byte-func)
(comp-func-c-name func) c-name
(comp-func-lap func) lap
(comp-func-frame-size func) (comp-byte-frame-size byte-func)
@@ -2079,7 +2085,8 @@ and the annotation emission."
(i (hash-table-count h)))
(puthash i (comp-func-doc f) h)
i)
- (comp-func-int-spec f)))
+ (comp-func-int-spec f)
+ (comp-func-command-modes f)))
;; This is the compilation unit it-self passed as
;; parameter.
(make-comp-mvar :slot 0))))))
@@ -2122,7 +2129,8 @@ These are stored in the reloc data array."
(i (hash-table-count h)))
(puthash i (comp-func-doc func) h)
i)
- (comp-func-int-spec func)))
+ (comp-func-int-spec func)
+ (comp-func-command-modes func)))
;; This is the compilation unit it-self passed as
;; parameter.
(make-comp-mvar :slot 0)))))
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 688c76e0c54..8a76eaf58cf 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -82,11 +82,9 @@ replacing its case-insensitive matches with the literal string in LIGHTER."
(replace-regexp-in-string (regexp-quote lighter) lighter name t t))))
(defconst easy-mmode--arg-docstring
- "
-
-This is a minor mode. If called interactively, toggle the `%s'
-mode. If the prefix argument is positive, enable the mode, and
-if it is zero or negative, disable the mode.
+ "This is a %sminor mode. If called interactively, toggle the
+`%s' mode. If the prefix argument is positive, enable the mode,
+and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'.
Enable the mode if ARG is nil, omitted, or is a positive number.
@@ -99,28 +97,50 @@ The mode's hook is called both when the mode is enabled and when
it is disabled.")
(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym
- getter)
- (let ((doc (or doc (format "Toggle %s on or off.
-
-\\{%s}" mode-pretty-name keymap-sym))))
- (if (string-match-p "\\bARG\\b" doc)
- doc
- (let* ((fill-prefix nil)
- (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column))
- (fill-column (if (integerp docs-fc) docs-fc 65))
- (argdoc (format easy-mmode--arg-docstring mode-pretty-name
- ;; Avoid having quotes turn into pretty quotes.
- (string-replace "'" "\\\\='"
- (format "%S" getter))))
- (filled (if (fboundp 'fill-region)
- (with-temp-buffer
- (insert argdoc)
- (fill-region (point-min) (point-max) 'left t)
- (buffer-string))
- argdoc)))
- (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'"
- (concat filled "\\1")
- doc nil nil 1)))))
+ getter global)
+ ;; If we have a doc string, and it's already complete (which we
+ ;; guess at with the simple heuristic below), then just return that
+ ;; as is.
+ (if (and doc (string-match-p "\\bARG\\b" doc))
+ doc
+ ;; Compose a new doc string.
+ (with-temp-buffer
+ (let ((lines (if doc
+ (string-lines doc)
+ (list (format "Toggle %s on or off." mode-pretty-name)))))
+ ;; Insert the first line from the doc string.
+ (insert (pop lines))
+ ;; Ensure that we have (only) one blank line after the first
+ ;; line.
+ (ensure-empty-lines)
+ (while (and lines
+ (equal (car lines) ""))
+ (pop lines))
+ ;; Insert the doc string.
+ (dolist (line lines)
+ (insert line "\n"))
+ (ensure-empty-lines)
+ ;; Insert the boilerplate.
+ (let* ((fill-prefix nil)
+ (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column))
+ (fill-column (if (integerp docs-fc) docs-fc 65))
+ (argdoc (format
+ easy-mmode--arg-docstring
+ (if global "global " "")
+ mode-pretty-name
+ ;; Avoid having quotes turn into pretty quotes.
+ (string-replace "'" "\\='" (format "%S" getter)))))
+ (let ((start (point)))
+ (insert argdoc)
+ (when (fboundp 'fill-region)
+ (fill-region start (point) 'left t))))
+ ;; Finally, insert the keymap.
+ (when (and (boundp keymap-sym)
+ (or (not doc)
+ (not (string-search "\\{" doc))))
+ (ensure-empty-lines)
+ (insert (format "\\{%s}" keymap-sym)))
+ (buffer-string)))))
;;;###autoload
(defalias 'easy-mmode-define-minor-mode #'define-minor-mode)
@@ -317,7 +337,7 @@ or call the function `%s'."))))
warnwrap
`(defun ,modefun (&optional arg ,@extra-args)
,(easy-mmode--mode-docstring doc pretty-name keymap-sym
- getter)
+ getter globalp)
,(when interactive
;; Use `toggle' rather than (if ,mode 0 1) so that using
;; repeat-command still does the toggling correctly.
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 19aa20fa086..d687289b22f 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -92,7 +92,7 @@ Currently under control of this var:
(:copier nil))
children
initarg-tuples ;; initarg tuples list
- (class-slots nil :type eieio--slot)
+ (class-slots nil :type (vector-of eieio--slot))
class-allocation-values ;; class allocated value vector
default-object-cache ;; what a newly created object would look like.
; This will speed up instantiation time as
@@ -130,10 +130,7 @@ Currently under control of this var:
class))
(defsubst eieio--object-class (obj)
- (let ((tag (eieio--object-class-tag obj)))
- (if eieio-backward-compatibility
- (eieio--class-object tag)
- tag)))
+ (eieio--class-object (eieio--object-class-tag obj)))
(defun class-p (x)
"Return non-nil if X is a valid class vector.
@@ -265,6 +262,10 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname)
(defvar eieio--known-slot-names nil)
(defvar eieio--known-class-slot-names nil)
+(defun eieio--known-slot-name-p (name)
+ (or (memq name eieio--known-slot-names)
+ (get name 'slot-name)))
+
(defun eieio-defclass-internal (cname superclasses slots options)
"Define CNAME as a new subclass of SUPERCLASSES.
SLOTS are the slots residing in that class definition, and OPTIONS
@@ -710,9 +711,9 @@ an error."
(cond
((not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type
- (list (eieio--class-name class) slot st value)))
+ (list (cl--class-name class) slot st value)))
((alist-get :read-only (cl--slot-descriptor-props sd))
- (signal 'eieio-read-only (list (eieio--class-name class) slot)))))))
+ (signal 'eieio-read-only (list (cl--class-name class) slot)))))))
(defun eieio--validate-class-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
@@ -725,7 +726,7 @@ an error."
slot-idx))))
(if (not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type
- (list (eieio--class-name class) slot st value))))))
+ (list (cl--class-name class) slot st value))))))
(defun eieio-barf-if-slot-unbound (value instance slotname fn)
"Throw a signal if VALUE is a representation of an UNBOUND slot.
@@ -746,31 +747,35 @@ Argument FN is the function calling this verifier."
(ignore obj)
(pcase slot
((and (or `',name (and name (pred keywordp)))
- (guard (not (memq name eieio--known-slot-names))))
+ (guard (not (eieio--known-slot-name-p name))))
(macroexp-warn-and-return
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only name))
(_ exp))))
+ ;; FIXME: Make it a gv-expander such that the hash-table lookup is
+ ;; only performed once when used in `push' and friends?
(gv-setter eieio-oset))
(cl-check-type slot symbol)
- (cl-check-type obj (or eieio-object class cl-structure-object))
- (let* ((class (cond ((symbolp obj)
- (error "eieio-oref called on a class: %s" obj)
- (eieio--full-class-object obj))
- (t (eieio--object-class obj))))
- (c (eieio--slot-name-index class slot)))
- (if (not c)
- ;; It might be missing because it is a :class allocated slot.
- ;; Let's check that info out.
- (if (setq c (eieio--class-slot-name-index class slot))
- ;; Oref that slot.
- (aref (eieio--class-class-allocation-values class) c)
- ;; The slot-missing method is a cool way of allowing an object author
- ;; to intercept missing slot definitions. Since it is also the LAST
- ;; thing called in this fn, its return value would be retrieved.
- (slot-missing obj slot 'oref))
- (cl-check-type obj (or eieio-object cl-structure-object))
- (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
+ (cond
+ ((cl-typep obj '(or eieio-object cl-structure-object))
+ (let* ((class (eieio--object-class obj))
+ (c (eieio--slot-name-index class slot)))
+ (if (not c)
+ ;; It might be missing because it is a :class allocated slot.
+ ;; Let's check that info out.
+ (if (setq c (eieio--class-slot-name-index class slot))
+ ;; Oref that slot.
+ (aref (eieio--class-class-allocation-values class) c)
+ ;; The slot-missing method is a cool way of allowing an object author
+ ;; to intercept missing slot definitions. Since it is also the LAST
+ ;; thing called in this fn, its return value would be retrieved.
+ (slot-missing obj slot 'oref))
+ (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
+ ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot))
+ (t
+ (signal 'wrong-type-argument
+ (list '(or eieio-object cl-structure-object oclosure) obj)))))
+
(defun eieio-oref-default (class slot)
@@ -782,7 +787,7 @@ Fills in CLASS's SLOT with its default value."
(ignore class)
(pcase slot
((and (or `',name (and name (pred keywordp)))
- (guard (not (memq name eieio--known-slot-names))))
+ (guard (not (eieio--known-slot-name-p name))))
(macroexp-warn-and-return
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only name))
@@ -817,24 +822,29 @@ Fills in CLASS's SLOT with its default value."
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
Fills in OBJ's SLOT with VALUE."
- (cl-check-type obj (or eieio-object cl-structure-object))
(cl-check-type slot symbol)
- (let* ((class (eieio--object-class obj))
- (c (eieio--slot-name-index class slot)))
- (if (not c)
- ;; It might be missing because it is a :class allocated slot.
- ;; Let's check that info out.
- (if (setq c
- (eieio--class-slot-name-index class slot))
- ;; Oset that slot.
- (progn
- (eieio--validate-class-slot-value class c value slot)
- (aset (eieio--class-class-allocation-values class)
- c value))
- ;; See oref for comment on `slot-missing'
- (slot-missing obj slot 'oset value))
- (eieio--validate-slot-value class c value slot)
- (aset obj c value))))
+ (cond
+ ((cl-typep obj '(or eieio-object cl-structure-object))
+ (let* ((class (eieio--object-class obj))
+ (c (eieio--slot-name-index class slot)))
+ (if (not c)
+ ;; It might be missing because it is a :class allocated slot.
+ ;; Let's check that info out.
+ (if (setq c
+ (eieio--class-slot-name-index class slot))
+ ;; Oset that slot.
+ (progn
+ (eieio--validate-class-slot-value class c value slot)
+ (aset (eieio--class-class-allocation-values class)
+ c value))
+ ;; See oref for comment on `slot-missing'
+ (slot-missing obj slot 'oset value))
+ (eieio--validate-slot-value class c value slot)
+ (aset obj c value))))
+ ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value))
+ (t
+ (signal 'wrong-type-argument
+ (list '(or eieio-object cl-structure-object oclosure) obj)))))
(defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'.
@@ -844,7 +854,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(ignore class value)
(pcase slot
((and (or `',name (and name (pred keywordp)))
- (guard (not (memq name eieio--known-slot-names))))
+ (guard (not (eieio--known-slot-name-p name))))
(macroexp-warn-and-return
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only name))
@@ -867,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(eieio--validate-class-slot-value class c value slot)
(aset (eieio--class-class-allocation-values class) c
value))
- (signal 'invalid-slot-name (list (eieio--class-name class) slot)))
+ (signal 'invalid-slot-name (list (cl--class-name class) slot)))
;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
;; not by CLOS and is mildly inconsistent with the :initform thingy, so
;; it'd be nice to get rid of it.
@@ -896,7 +906,7 @@ The slot is a symbol which is installed in CLASS by the `defclass' call.
If SLOT is the value created with :initarg instead,
reverse-lookup that name, and recurse with the associated slot value."
;; Removed checks to outside this call
- (let* ((fsi (gethash slot (eieio--class-index-table class))))
+ (let* ((fsi (gethash slot (cl--class-index-table class))))
(if (integerp fsi)
fsi
(let ((fn (eieio--initarg-to-attribute class slot)))
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 73713a3dec9..74ffeb166d4 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -5,7 +5,7 @@
;; Author: Noah Friedman <friedman@splode.com>
;; Keywords: extensions
;; Created: 1995-10-06
-;; Version: 1.11.0
+;; Version: 1.11.1
;; Package-Requires: ((emacs "26.3"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@@ -102,7 +102,7 @@ put in the echo area. If a positive integer, the number is used
directly, while a float specifies the number of lines as a
proportion of the echo area frame's height.
-If value is the symbol `truncate-sym-name-if-fit' t, the part of
+If value is the symbol `truncate-sym-name-if-fit', the part of
the doc string that represents a symbol's name may be truncated
if it will enable the rest of the doc string to fit on a single
line, without resizing the echo area.
@@ -525,7 +525,8 @@ Helper for `eldoc-display-in-echo-area'."
(goto-char (point-min))
(skip-chars-forward " \t\n")
(point))
- (goto-char (line-end-position available))
+ (forward-visible-line (1- available))
+ (end-of-visible-line)
(skip-chars-backward " \t\n")))
(truncated (save-excursion
(skip-chars-forward " \t\n")
@@ -535,7 +536,8 @@ Helper for `eldoc-display-in-echo-area'."
((and truncated
(> available 1)
eldoc-echo-area-display-truncation-message)
- (goto-char (line-end-position 0))
+ (forward-visible-line -1)
+ (end-of-visible-line)
(concat (buffer-substring start (point))
(format
"\n(Documentation truncated. Use `%s' to see rest)"
@@ -610,7 +612,8 @@ Honor `eldoc-echo-area-use-multiline-p' and
(let ((string
(with-current-buffer (eldoc--format-doc-buffer docs)
(buffer-substring (goto-char (point-min))
- (line-end-position 1)))))
+ (progn (end-of-visible-line)
+ (point))))))
(if (> (length string) width) ; truncation to happen
(unless (eldoc--echo-area-prefer-doc-buffer-p t)
(truncate-string-to-width string width))
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index e91b302af10..e4bc2df2803 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -567,12 +567,20 @@ cases where EXP is a constant."
(defmacro macroexp-let2* (test bindings &rest body)
"Multiple binding version of `macroexp-let2'.
-BINDINGS is a list of elements of the form (SYM EXP). Each EXP
-can refer to symbols specified earlier in the binding list."
+BINDINGS is a list of elements of the form (SYM EXP) or just SYM,
+which then stands for (SYM SYM).
+Each EXP can refer to symbols specified earlier in the binding list.
+
+TEST has to be a symbol, and if it is nil it can be omitted."
(declare (indent 2) (debug (sexp (&rest (sexp form)) body)))
+ (when (consp test) ;; `test' was omitted.
+ (push bindings body)
+ (setq bindings test)
+ (setq test nil))
(pcase-exhaustive bindings
('nil (macroexp-progn body))
- (`((,var ,exp) . ,tl)
+ (`(,(or `(,var ,exp) (and (pred symbolp) var (let exp var)))
+ . ,tl)
`(macroexp-let2 ,test ,var ,exp
(macroexp-let2* ,test ,tl ,@body)))))
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index b3e7fca4781..c47025f8846 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -278,11 +278,17 @@ Type \\`SPC' or \\`y' to %s the current %s;
;; For backward compatibility check if short y/n answers are preferred.
(defcustom read-answer-short 'auto
- "If non-nil, `read-answer' accepts single-character answers.
+ "If non-nil, the `read-answer' function accepts single-character answers.
If t, accept short (single key-press) answers to the question.
If nil, require long answers. If `auto', accept short answers if
`use-short-answers' is non-nil, or the function cell of `yes-or-no-p'
-is set to `y-or-n-p'."
+is set to `y-or-n-p'.
+
+Note that this variable does not affect calls to the more
+commonly-used `yes-or-no-p' function; it only affects calls to
+the `read-answer' function. To control whether `yes-or-no-p'
+requires a long or a short answer, see the `use-short-answers'
+variable."
:type '(choice (const :tag "Accept short answers" t)
(const :tag "Require long answer" nil)
(const :tag "Guess preference" auto))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
new file mode 100644
index 00000000000..90811199f25
--- /dev/null
+++ b/lisp/emacs-lisp/oclosure.el
@@ -0,0 +1,555 @@
+;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; An OClosure is an object that combines the properties of records
+;; with those of a function. More specifically it is a function extended
+;; with a notion of type (e.g. for defmethod dispatch) as well as the
+;; ability to have some fields that are accessible from the outside.
+
+;; See "Open closures", ELS'2022 (https://zenodo.org/record/6228797).
+
+;; Here are some cases of "callable objects" where OClosures have found use:
+;; - nadvice.el (the original motivation)
+;; - kmacros (for cl-print and for `kmacro-extract-lambda')
+;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test
+;; (by putting the no-next-methods into their own class).
+;; - Slot accessor functions, where the type-dispatch can be used to
+;; dynamically compute the docstring, and also to pretty print them.
+;; - `save-some-buffers-function'
+;; Here are other cases of "callable objects" where OClosures could be used:
+;; - Use the type to distinguish macros from functions.
+;; - Use a `name' and `depth' property from the function passed to
+;; `add-function' (or `add-hook') instead of passing it via "props".
+;; - iterators (generator.el), thunks (thunk.el), streams (stream.el).
+;; - PEG rules: they're currently just functions, but they should carry
+;; their original (macro-expanded) definition (and should be printed
+;; differently from functions)!
+;; - auto-generate docstrings for cl-defstruct slot accessors instead of
+;; storing them in the accessor itself?
+;; - SRFI-17's `setter'.
+;; - coercion wrappers, as in "Threesomes, with and without blame"
+;; https://dl.acm.org/doi/10.1145/1706299.1706342, or
+;; "On the Runtime Complexity of Type-Directed Unboxing"
+;; http://sv.c.titech.ac.jp/minamide/papers.html
+;; - An efficient `negate' operation such that
+;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=.
+;; - Autoloads (tho currently our bytecode functions (and hence OClosures)
+;; are too fat for that).
+
+;; Related constructs:
+;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different
+;; from OClosures in that they involve an additional indirection to get
+;; to the actual code, and that they offer the possibility of
+;; changing (via mutation) the code associated with
+;; an FSO. Also the FSO's function can't directly access the FSO's
+;; other fields, contrary to the case with OClosures where those are directly
+;; available as local variables.
+;; - Function objects in Javascript.
+;; - Function objects in Python.
+;; - Callable/Applicable classes in OO languages, i.e. classes with
+;; a single method called `apply' or `call'. The most obvious
+;; difference with OClosures (beside the fact that Callable can be
+;; extended with additional methods) is that all instances of
+;; a given Callable class have to use the same method, whereas every
+;; OClosure object comes with its own code, so two OClosure objects of the
+;; same type can have different code. Of course, you can get the
+;; same result by turning every `oclosure-lambda' into its own class
+;; declaration creating an ad-hoc subclass of the specified type.
+;; In this sense, OClosures are just a generalization of `lambda' which brings
+;; some of the extra feature of Callable objects.
+;; - Apply hooks and "entities" in MIT Scheme
+;; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html
+;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities"
+;; are a variant of it where the inner function gets the FSO itself as
+;; additional argument (a kind of "self" arg), thus making it easier
+;; for the code to get data from the object's extra info, tho still
+;; not as easy as with OClosures.
+;; - "entities" in Lisp Machine Lisp (LML)
+;; https://hanshuebner.github.io/lmman/fd-clo.xml
+;; These are arguably identical to OClosures, modulo the fact that LML doesn't
+;; have lexically-scoped closures and uses a form of closures based on
+;; capturing (and reinstating) dynamically scoped bindings instead.
+
+;; Naming: OClosures were originally named FunCallableRecords (FCR), but
+;; that name suggested these were fundamentally records that happened
+;; to be called, whereas OClosures are really just closures that happen
+;; to enjoy some characteristics of records.
+;; The "O" comes from "Open" because OClosures aren't completely opaque
+;; (for that same reason, an alternative name suggested at the time was
+;; "disclosures").
+;; The "O" can also be understood to mean "Object" since you have notions
+;; of inheritance, and the ability to associate methods with particular
+;; OClosure types, just as is the case for OO classes.
+
+;;; Code:
+
+;; TODO:
+;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'?
+;; - Use accessor in cl-defstruct.
+;; - Add pcase patterns for OClosures.
+;; - anonymous OClosure types.
+;; - copiers for mixins
+;; - class-allocated slots?
+;; - code-allocated slots?
+;; The `where' slot of `advice' would like to be code-allocated, and the
+;; interactive-spec of commands is currently code-allocated but would like
+;; to be instance-allocated. Their scoping rules are a bit odd, so maybe
+;; it's best to avoid them.
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x)) ;For `named-let'.
+
+(defun oclosure--index-table (slotdescs)
+ (let ((i -1)
+ (it (make-hash-table :test #'eq)))
+ (dolist (desc slotdescs)
+ (let* ((slot (cl--slot-descriptor-name desc)))
+ (cl-incf i)
+ (when (gethash slot it)
+ (error "Duplicate slot name: %S" slot))
+ (setf (gethash slot it) i)))
+ it))
+
+(cl-defstruct (oclosure--class
+ (:constructor nil)
+ (:constructor oclosure--class-make
+ ( name docstring slots parents allparents
+ &aux (index-table (oclosure--index-table slots))))
+ (:include cl--class)
+ (:copier nil))
+ "Metaclass for OClosure classes."
+ (allparents nil :read-only t :type (list-of symbol)))
+
+(setf (cl--find-class 'oclosure)
+ (oclosure--class-make 'oclosure
+ "The root parent of all OClosure classes"
+ nil nil '(oclosure)))
+(defun oclosure--p (oclosure)
+ (not (not (oclosure-type oclosure))))
+
+(cl-deftype oclosure () '(satisfies oclosure--p))
+
+(defun oclosure--slot-mutable-p (slotdesc)
+ (not (alist-get :read-only (cl--slot-descriptor-props slotdesc))))
+
+(defun oclosure--defstruct-make-copiers (copiers slotdescs name)
+ (require 'cl-macs) ;`cl--arglist-args' is not autoloaded.
+ (let* ((mutables '())
+ (slots (mapcar
+ (lambda (desc)
+ (let ((name (cl--slot-descriptor-name desc)))
+ (when (oclosure--slot-mutable-p desc)
+ (push name mutables))
+ name))
+ slotdescs)))
+ (mapcar
+ (lambda (copier)
+ (pcase-let*
+ ((cname (pop copier))
+ (args (or (pop copier) `(&key ,@slots)))
+ (inline (and (eq :inline (car copier)) (pop copier)))
+ (doc (or (pop copier)
+ (format "Copier for objects of type `%s'." name)))
+ (obj (make-symbol "obj"))
+ (absent (make-symbol "absent"))
+ (anames (cl--arglist-args args))
+ (mnames
+ (let ((res '())
+ (tmp args))
+ (while (and tmp
+ (not (memq (car tmp)
+ cl--lambda-list-keywords)))
+ (push (pop tmp) res))
+ res))
+ (index -1)
+ (mutlist '())
+ (argvals
+ (mapcar
+ (lambda (slot)
+ (setq index (1+ index))
+ (let* ((mutable (memq slot mutables))
+ (get `(oclosure--get ,obj ,index ,(not (not mutable)))))
+ (push mutable mutlist)
+ (cond
+ ((not (memq slot anames)) get)
+ ((memq slot mnames) slot)
+ (t
+ `(if (eq ',absent ,slot)
+ ,get
+ ,slot)))))
+ slots)))
+ `(,(if inline 'cl-defsubst 'cl-defun) ,cname
+ (&cl-defs (',absent) ,obj ,@args)
+ ,doc
+ (declare (side-effect-free t))
+ (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist))
+ ,@argvals))))
+ copiers)))
+
+
+(defmacro oclosure-define (name &optional docstring &rest slots)
+ "Define a new OClosure type.
+NAME should be a symbol which is the name of the new type.
+It can also be of the form (NAME . PROPS) in which case PROPS
+is a list of additional properties among the following:
+ (:predicate PRED): asks to create a predicate function named PRED.
+ (:parent TYPE): make TYPE (another OClosure type) be a parent of NAME.
+ (:copier COPIER ARGS): asks to create a \"copier\" (i.e. functional update
+ function) named COPIER. It will take an object of type NAME as first
+ argument followed by ARGS. ARGS lists the names of the slots that will
+ be updated with the value of the corresponding argument.
+SLOTS is a list if slot descriptions. Each slot can be a single symbol
+which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS)
+where SLOT-NAME is then the name of the slot and SPROPS is a property
+list of slot properties. The currently known properties are the following:
+ `:mutable': A non-nil value mean the slot can be mutated.
+ `:type': Specifies the type of the values expected to appear in the slot."
+ (declare (doc-string 2) (indent 1))
+ (unless (stringp docstring)
+ (push docstring slots)
+ (setq docstring nil))
+ (let* ((options (when (consp name)
+ (prog1 (copy-sequence (cdr name))
+ (setq name (car name)))))
+ (get-opt (lambda (opt &optional all)
+ (let ((val (assq opt options))
+ tmp)
+ (when val (setq options (delq val options)))
+ (if (not all)
+ (cdr val)
+ (when val
+ (setq val (list (cdr val)))
+ (while (setq tmp (assq opt options))
+ (push (cdr tmp) val)
+ (setq options (delq tmp options)))
+ (nreverse val))))))
+ (predicate (car (funcall get-opt :predicate)))
+ (parent-names (or (funcall get-opt :parent)
+ (funcall get-opt :include)))
+ (copiers (funcall get-opt :copier 'all)))
+ `(progn
+ ,(when options (macroexp-warn-and-return name
+ (format "Ignored options: %S" options)
+ nil))
+ (eval-and-compile
+ (oclosure--define ',name ,docstring ',parent-names ',slots
+ ,@(when predicate `(:predicate ',predicate))))
+ (oclosure--define-functions ,name ,copiers))))
+
+(defun oclosure--build-class (name docstring parent-names slots)
+ (cl-assert (null (cdr parent-names)))
+ (let* ((parent-class (let ((name (or (car parent-names) 'oclosure)))
+ (or (cl--find-class name)
+ (error "Unknown class: %S" name))))
+ (slotdescs
+ (append
+ (oclosure--class-slots parent-class)
+ (mapcar (lambda (field)
+ (if (not (consp field))
+ (cl--make-slot-descriptor field nil nil
+ '((:read-only . t)))
+ (let ((name (pop field))
+ (type nil)
+ (read-only t)
+ (props '()))
+ (while field
+ (pcase (pop field)
+ (:mutable (setq read-only (not (car field))))
+ (:type (setq type (car field)))
+ (p (message "Unknown property: %S" p)
+ (push (cons p (car field)) props)))
+ (setq field (cdr field)))
+ (cl--make-slot-descriptor name nil type
+ `((:read-only . ,read-only)
+ ,@props)))))
+ slots))))
+ (oclosure--class-make name docstring slotdescs
+ (if (cdr parent-names)
+ (oclosure--class-parents parent-class)
+ (list parent-class))
+ (cons name (oclosure--class-allparents
+ parent-class)))))
+
+(defmacro oclosure--define-functions (name copiers)
+ (let* ((class (cl--find-class name))
+ (slotdescs (oclosure--class-slots class)))
+ `(progn
+ ,@(let ((i -1))
+ (mapcar (lambda (desc)
+ (let* ((slot (cl--slot-descriptor-name desc))
+ (mutable (oclosure--slot-mutable-p desc))
+ ;; Always use a double hyphen: if users wants to
+ ;; make it public, they can do so with an alias.
+ (aname (intern (format "%S--%S" name slot))))
+ (cl-incf i)
+ (if (not mutable)
+ `(defalias ',aname
+ ;; We use `oclosure--copy' instead of
+ ;; `oclosure--accessor-copy' here to circumvent
+ ;; bootstrapping problems.
+ (oclosure--copy
+ oclosure--accessor-prototype
+ nil ',name ',slot ,i))
+ (require 'gv) ;For `gv-setter'.
+ `(progn
+ (defalias ',aname
+ (oclosure--accessor-copy
+ oclosure--mut-getter-prototype
+ ',name ',slot ,i))
+ (defalias ',(gv-setter aname)
+ (oclosure--accessor-copy
+ oclosure--mut-setter-prototype
+ ',name ',slot ,i))))))
+ slotdescs))
+ ,@(oclosure--defstruct-make-copiers
+ copiers slotdescs name))))
+
+;;;###autoload
+(defun oclosure--define (name docstring parent-names slots
+ &rest props)
+ (let* ((class (oclosure--build-class name docstring parent-names slots))
+ (pred (lambda (oclosure)
+ (let ((type (oclosure-type oclosure)))
+ (when type
+ (memq name (oclosure--class-allparents
+ (cl--find-class type)))))))
+ (predname (or (plist-get props :predicate)
+ (intern (format "%s--internal-p" name)))))
+ (setf (cl--find-class name) class)
+ (dolist (slot (oclosure--class-slots class))
+ (put (cl--slot-descriptor-name slot) 'slot-name t))
+ (defalias predname pred)
+ (put name 'cl-deftype-satisfies predname)))
+
+(defmacro oclosure--lambda (type bindings mutables args &rest body)
+ "Low level construction of an OClosure object.
+TYPE should be a form returning an OClosure type (a symbol)
+BINDINGS should list all the slots expected by this type, in the proper order.
+MUTABLE is a list of symbols indicating which of the BINDINGS
+should be mutable.
+No checking is performed,"
+ (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
+ ;; FIXME: Fundamentally `oclosure-lambda' should be a special form.
+ ;; We define it here as a macro which expands to something that
+ ;; looks like "normal code" in order to avoid backward compatibility
+ ;; issues with third party macros that do "code walks" and would
+ ;; likely mishandle such a new special form (e.g. `generator.el').
+ ;; But don't be fooled: this macro is tightly bound to `cconv.el'.
+ (pcase-let*
+ ((`(,prebody . ,body) (macroexp-parse-body body))
+ (rovars (mapcar #'car bindings)))
+ (dolist (mutable mutables)
+ (setq rovars (delq mutable rovars)))
+ `(let ,(mapcar (lambda (bind)
+ (if (cdr bind) bind
+ ;; Bind to something that doesn't look
+ ;; like a value to avoid the "Variable
+ ;; ‘foo’ left uninitialized" warning.
+ `(,(car bind) (progn nil))))
+ (reverse bindings))
+ ;; FIXME: Make sure the slotbinds whose value is duplicable aren't
+ ;; just value/variable-propagated by the optimizer (tho I think our
+ ;; optimizer is too naive to be a problem currently).
+ (oclosure--fix-type
+ ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in
+ ;; `cconv.el') to detect and signal an error in case of
+ ;; store-conversion (i.e. if a variable/slot is mutated).
+ (ignore ,@rovars)
+ (lambda ,args
+ (:documentation ,type)
+ ,@prebody
+ ;; Add dummy code which accesses the field's vars to make sure
+ ;; they're captured in the closure.
+ (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables))
+ ,@body)))))
+
+(defmacro oclosure-lambda (type-and-slots args &rest body)
+ "Define anonymous OClosure function.
+TYPE-AND-SLOTS should be of the form (TYPE . SLOTS)
+where TYPE is an OClosure type name (defined by `oclosure-define')
+and SLOTS is a let-style list of bindings for the various slots of TYPE.
+ARGS and BODY are the same as for `lambda'."
+ (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body)))
+ ;; FIXME: Should `oclosure-define' distinguish "optional" from
+ ;; "mandatory" slots, and/or provide default values for slots missing
+ ;; from `fields'?
+ (pcase-let*
+ ((`(,type . ,fields) type-and-slots)
+ (class (or (cl--find-class type)
+ (error "Unknown class: %S" type)))
+ (slots (oclosure--class-slots class))
+ (mutables '())
+ (slotbinds (mapcar (lambda (slot)
+ (let ((name (cl--slot-descriptor-name slot)))
+ (when (oclosure--slot-mutable-p slot)
+ (push name mutables))
+ (list name)))
+ slots))
+ (tempbinds (mapcar
+ (lambda (field)
+ (let* ((name (car field))
+ (bind (assq name slotbinds)))
+ (cond
+ ;; FIXME: Should we also warn about missing slots?
+ ((not bind)
+ (error "Unknown slot: %S" name))
+ ((cdr bind)
+ (error "Duplicate slot: %S" name))
+ (t
+ (let ((temp (gensym "temp")))
+ (setcdr bind (list temp))
+ (cons temp (cdr field)))))))
+ fields)))
+ ;; FIXME: Optimize temps away when they're provided in the right order?
+ `(let ,tempbinds
+ (oclosure--lambda ',type ,slotbinds ,mutables ,args ,@body))))
+
+(defun oclosure--fix-type (_ignore oclosure)
+ "Helper function to implement `oclosure-lambda' via a macro.
+This has 2 uses:
+- For interpreted code, this converts the representation of type information
+ by moving it from the docstring to the environment.
+- For compiled code, this is used as a marker which cconv uses to check that
+ immutable fields are indeed not mutated."
+ (if (byte-code-function-p oclosure)
+ ;; Actually, this should never happen since the `cconv.el' should have
+ ;; optimized away the call to this function.
+ oclosure
+ ;; For byte-coded functions, we store the type as a symbol in the docstring
+ ;; slot. For interpreted functions, there's no specific docstring slot
+ ;; so `Ffunction' turns the symbol into a string.
+ ;; We thus have convert it back into a symbol (via `intern') and then
+ ;; stuff it into the environment part of the closure with a special
+ ;; marker so we can distinguish this entry from actual variables.
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (let ((typename (nth 3 oclosure))) ;; The "docstring".
+ (cl-assert (stringp typename))
+ (push (cons :type (intern typename))
+ (cadr oclosure))
+ oclosure)))
+
+(defun oclosure--copy (oclosure mutlist &rest args)
+ (if (byte-code-function-p oclosure)
+ (apply #'make-closure oclosure
+ (if (null mutlist)
+ args
+ (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args)))
+ (cl-assert (eq 'closure (car-safe oclosure))
+ nil "oclosure not closure: %S" oclosure)
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (let ((env (cadr oclosure)))
+ `(closure
+ (,(car env)
+ ,@(named-let loop ((env (cdr env)) (args args))
+ (when args
+ (cons (cons (caar env) (car args))
+ (loop (cdr env) (cdr args)))))
+ ,@(nthcdr (1+ (length args)) env))
+ ,@(nthcdr 2 oclosure)))))
+
+(defun oclosure--get (oclosure index mutable)
+ (if (byte-code-function-p oclosure)
+ (let* ((csts (aref oclosure 2))
+ (v (aref csts index)))
+ (if mutable (car v) v))
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (cdr (nth (1+ index) (cadr oclosure)))))
+
+(defun oclosure--set (v oclosure index)
+ (if (byte-code-function-p oclosure)
+ (let* ((csts (aref oclosure 2))
+ (cell (aref csts index)))
+ (setcar cell v))
+ (cl-assert (eq 'closure (car-safe oclosure)))
+ (cl-assert (eq :type (caar (cadr oclosure))))
+ (setcdr (nth (1+ index) (cadr oclosure)) v)))
+
+(defun oclosure-type (oclosure)
+ "Return the type of OCLOSURE, or nil if the arg is not a OClosure."
+ (if (byte-code-function-p oclosure)
+ (let ((type (and (> (length oclosure) 4) (aref oclosure 4))))
+ (if (symbolp type) type))
+ (and (eq 'closure (car-safe oclosure))
+ (let* ((env (car-safe (cdr oclosure)))
+ (first-var (car-safe env)))
+ (and (eq :type (car-safe first-var))
+ (cdr first-var))))))
+
+(defconst oclosure--accessor-prototype
+ ;; Use `oclosure--lambda' to circumvent a bootstrapping problem:
+ ;; `oclosure-accessor' is not yet defined at this point but
+ ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'.
+ (oclosure--lambda 'oclosure-accessor ((type) (slot) (index)) nil
+ (oclosure) (oclosure--get oclosure index nil)))
+
+(oclosure-define accessor
+ "OClosure function to access a specific slot of an object."
+ type slot)
+
+(defun oclosure--accessor-docstring (f)
+ ;; This would like to be a (cl-defmethod function-documentation ...)
+ ;; but for circularity reason the defmethod is in `simple.el'.
+ (format "Access slot \"%S\" of OBJ of type `%S'.\n\n(fn OBJ)"
+ (accessor--slot f) (accessor--type f)))
+
+(oclosure-define (oclosure-accessor
+ (:parent accessor)
+ (:copier oclosure--accessor-copy (type slot index)))
+ "OClosure function to access a specific slot of an OClosure function."
+ index)
+
+(defun oclosure--slot-index (oclosure slotname)
+ (gethash slotname
+ (oclosure--class-index-table
+ (cl--find-class (oclosure-type oclosure)))))
+
+(defun oclosure--slot-value (oclosure slotname)
+ (let ((class (cl--find-class (oclosure-type oclosure)))
+ (index (oclosure--slot-index oclosure slotname)))
+ (oclosure--get oclosure index
+ (oclosure--slot-mutable-p
+ (nth index (oclosure--class-slots class))))))
+
+(defun oclosure--set-slot-value (oclosure slotname value)
+ (let ((class (cl--find-class (oclosure-type oclosure)))
+ (index (oclosure--slot-index oclosure slotname)))
+ (unless (oclosure--slot-mutable-p
+ (nth index (oclosure--class-slots class)))
+ (signal 'setting-constant (list oclosure slotname)))
+ (oclosure--set value oclosure index)))
+
+(defconst oclosure--mut-getter-prototype
+ (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure)
+ (oclosure--get oclosure index t)))
+(defconst oclosure--mut-setter-prototype
+ ;; FIXME: The generated docstring is wrong.
+ (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure)
+ (oclosure--set val oclosure index)))
+
+;; Ideally, this should be in `files.el', but that file is loaded
+;; before `oclosure.el'.
+(oclosure-define (save-some-buffers-function
+ (:predicate save-some-buffers-function--p)))
+
+
+(provide 'oclosure)
+;;; oclosure.el ends here
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index fe6b1e639fc..b42dc06c6c2 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -1855,8 +1855,12 @@ SEEN is used internally to detect infinite recursion."
(error "Need package `%s-%s', but only %s is available"
next-pkg (package-version-join next-version)
found-something))
- (t (error "Package `%s-%s' is unavailable"
- next-pkg (package-version-join next-version)))))
+ (t
+ (if (eq next-pkg 'emacs)
+ (error "This package requires Emacs version %s"
+ (package-version-join next-version))
+ (error "Package `%s-%s' is unavailable"
+ next-pkg (package-version-join next-version))))))
(setq packages
(package-compute-transaction (cons found packages)
(package-desc-reqs found)
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index e782cdb1dab..ad693fa5a61 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -177,6 +177,10 @@ Also add the value to the front of the list in the variable `values'."
(let ((pt (point)))
(save-excursion
(forward-sexp -1)
+ ;; Make `pp-eval-last-sexp' work the same way `eval-last-sexp'
+ ;; does.
+ (when (looking-at ",@?")
+ (goto-char (match-end 0)))
(read
;; If first line is commented, ignore all leading comments:
(if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;"))
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 1bcb844d8e9..133d3c9e118 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -403,15 +403,14 @@ found or not."
(setq count (+ 1 count))))
count))
-(with-suppressed-warnings ((obsolete seq-contains))
- (cl-defgeneric seq-contains (sequence elt &optional testfn)
- "Return the first element in SEQUENCE that is equal to ELT.
+(cl-defgeneric seq-contains (sequence elt &optional testfn)
+ "Return the first element in SEQUENCE that is equal to ELT.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (declare (obsolete seq-contains-p "27.1"))
- (seq-some (lambda (e)
- (when (funcall (or testfn #'equal) elt e)
- e))
- sequence)))
+ (declare (obsolete seq-contains-p "27.1"))
+ (seq-some (lambda (e)
+ (when (funcall (or testfn #'equal) elt e)
+ e))
+ sequence))
(cl-defgeneric seq-contains-p (sequence elt &optional testfn)
"Return non-nil if SEQUENCE contains an element equal to ELT.
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 658edd67527..ebf3c6b1fe9 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -47,30 +47,67 @@
"Add GROUP to the list of defined documentation groups.
FUNCTIONS is a list of elements on the form:
- (fun
+ (FUNC
:no-manual BOOL
:args ARGS
- :eval EXAMPLE-FORM
+ :eval EVAL
:no-eval EXAMPLE-FORM
- :no-eval* EXAMPLE-FORM
:no-value EXAMPLE-FORM
+ :no-eval* EXAMPLE-FORM
:result RESULT-FORM
- :result-string RESULT-FORM
+ :result-string RESULT-STRING
:eg-result RESULT-FORM
- :eg-result-string RESULT-FORM)
+ :eg-result-string RESULT-STRING)
-BOOL should be non-nil if the function isn't documented in the
+FUNC is the function being documented.
+
+NO-MANUAL should be non-nil if FUNC isn't documented in the
manual.
-ARGS is optional; the function's signature is displayed if ARGS
-is not present.
+ARGS is optional list of function FUNC's arguments. FUNC's
+signature is displayed automatically if ARGS is not present.
+Specifying ARGS might be useful where you don't want to document
+some of the uncommon arguments a function might have.
+
+While the `:no-manual' and `:args' property can be used for
+any (FUNC ..) form, all of the other properties shown above
+cannot be used simultaneously in such a form.
-If EVAL isn't a string, it will be printed with `prin1', and then
-evaluated to give a result, which is also printed. If it's a
-string, it'll be inserted as is, then the string will be `read',
-and then evaluated.
+Here are some common forms with examples of properties that go
+together:
-There can be any number of :example/:result elements."
+1. Document a form or string, and its evaluated return value.
+ (FUNC
+ :eval EVAL)
+
+If EVAL is a string, it will be inserted as is, and then that
+string will be `read' and evaluated.
+
+2. Document a form or string, but manually document its evalation
+ result. The provided form will not be evaluated.
+
+ (FUNC
+ :no-eval EXAMPLE-FORM
+ :result RESULT-FORM ;Use `:result-string' if value is in string form
+ )
+
+Using `:no-value' is the same as using `:no-eval'.
+
+Use `:no-eval*' instead of `:no-eval' where the successful
+execution of the documented form depends on some conditions.
+
+3. Document a form or string EXAMPLE-FORM. Also manually
+ document an example result. This result could be unrelated to
+ the documented form.
+
+ (FUNC
+ :no-eval EXAMPLE-FORM
+ :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form
+ )
+
+A FUNC form can have any number of `:no-eval' (or `:no-value'),
+`:no-eval*', `:result', `:result-string', `:eg-result' and
+`:eg-result-string' properties."
(declare (indent defun))
`(progn
(setq shortdoc--groups (delq (assq ',group shortdoc--groups)
@@ -1408,11 +1445,14 @@ function's documentation in the Info manual")))
If GROUP doesn't exist, it will be created.
If SECTION doesn't exist, it will be added.
+ELEM is a Lisp form. See `define-short-documentation-group' for
+details.
+
Example:
(shortdoc-add-function
- 'file \"Predicates\"
- '(file-locked-p :no-eval (file-locked-p \"/tmp\")))"
+ \\='file \"Predicates\"
+ \\='(file-locked-p :no-eval (file-locked-p \"/tmp\")))"
(let ((glist (assq group shortdoc--groups)))
(unless glist
(setq glist (list group))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 7ad4e9ba2ab..abf85ab6c67 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -320,12 +320,6 @@ than this function."
(end (substring string (- (length string) length)))
(t (substring string 0 length)))))
-;;;###autoload
-(defun string-lines (string &optional omit-nulls)
- "Split STRING into a list of lines.
-If OMIT-NULLS, empty lines will be removed from the results."
- (split-string string "\n" omit-nulls))
-
(defun string-pad (string length &optional padding start)
"Pad STRING to LENGTH using PADDING.
If PADDING is nil, the space character is used. If not nil, it
@@ -414,32 +408,6 @@ and return the value found in PLACE instead."
,(funcall setter val)
,val)))))
-;;;###autoload
-(defun ensure-empty-lines (&optional lines)
- "Ensure that there are LINES number of empty lines before point.
-If LINES is nil or omitted, ensure that there is a single empty
-line before point.
-
-If called interactively, LINES is given by the prefix argument.
-
-If there are more than LINES empty lines before point, the number
-of empty lines is reduced to LINES.
-
-If point is not at the beginning of a line, a newline character
-is inserted before adjusting the number of empty lines."
- (interactive "p")
- (unless (bolp)
- (insert "\n"))
- (let ((lines (or lines 1))
- (start (save-excursion
- (if (re-search-backward "[^\n]" nil t)
- (+ (point) 2)
- (point-min)))))
- (cond
- ((> (- (point) start) lines)
- (delete-region (point) (- (point) (- (point) start lines))))
- ((< (- (point) start) lines)
- (insert (make-string (- lines (- (point) start)) ?\n))))))
;;;###autoload
(defun string-pixel-width (string)
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index cc4143bfa23..59bfd246036 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -768,7 +768,7 @@ the matching regexp, or nil if none found."
PROC is the process-object of the DCC connection. Returns the number of
bytes sent."
(let* ((elt (erc-dcc-member :peer proc))
- (confirmed-marker (plist-get elt :sent))
+ (confirmed-marker (plist-get elt :confirmed))
(sent-marker (plist-get elt :sent)))
(with-current-buffer (process-buffer proc)
(when erc-dcc-verbose
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 9ee8d38b026..52fe106f2d1 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -1761,12 +1761,7 @@ nil."
(lambda (bufname)
(let ((buf (if (consp bufname)
(cdr bufname) (get-buffer bufname))))
- (when buf
- (erc--buffer-p buf (lambda () t) proc)
- (with-current-buffer buf
- (and (derived-mode-p 'erc-mode)
- (or (null proc)
- (eq proc erc-server-process))))))))))
+ (and buf (erc--buffer-p buf (lambda () t) proc)))))))
(defun erc-switch-to-buffer (&optional arg)
"Prompt for an ERC buffer to switch to.
When invoked with prefix argument, use all ERC buffers. Without
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index ba868cee59e..448b6787ee7 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -155,39 +155,37 @@ or `eshell-printn' for display."
"umask" args
'((?S "symbolic" nil symbolic-p "display umask symbolically")
(?h "help" nil nil "display this usage message")
+ :preserve-args
:usage "[-S] [mode]")
- (if (or (not args) symbolic-p)
- (let ((modstr
- (concat "000"
- (format "%o"
- (logand (lognot (default-file-modes))
- 511)))))
- (setq modstr (substring modstr (- (length modstr) 3)))
- (when symbolic-p
- (let ((mode (default-file-modes)))
- (setq modstr
- (format
- "u=%s,g=%s,o=%s"
- (concat (and (= (logand mode 64) 64) "r")
- (and (= (logand mode 128) 128) "w")
- (and (= (logand mode 256) 256) "x"))
- (concat (and (= (logand mode 8) 8) "r")
- (and (= (logand mode 16) 16) "w")
- (and (= (logand mode 32) 32) "x"))
- (concat (and (= (logand mode 1) 1) "r")
- (and (= (logand mode 2) 2) "w")
- (and (= (logand mode 4) 4) "x"))))))
- (eshell-printn modstr))
- (setcar args (eshell-convert (car args)))
- (if (numberp (car args))
- (set-default-file-modes
- (- 511 (car (read-from-string
- (concat "?\\" (number-to-string (car args)))))))
- (error "Setting umask symbolically is not yet implemented"))
+ (cond
+ (symbolic-p
+ (let ((mode (default-file-modes)))
+ (eshell-printn
+ (format "u=%s,g=%s,o=%s"
+ (concat (and (= (logand mode 64) 64) "r")
+ (and (= (logand mode 128) 128) "w")
+ (and (= (logand mode 256) 256) "x"))
+ (concat (and (= (logand mode 8) 8) "r")
+ (and (= (logand mode 16) 16) "w")
+ (and (= (logand mode 32) 32) "x"))
+ (concat (and (= (logand mode 1) 1) "r")
+ (and (= (logand mode 2) 2) "w")
+ (and (= (logand mode 4) 4) "x"))))))
+ ((not args)
+ (eshell-printn (format "%03o" (logand (lognot (default-file-modes))
+ #o777))))
+ (t
+ (when (stringp (car args))
+ (if (string-match "^[0-7]+$" (car args))
+ (setcar args (string-to-number (car args) 8))
+ (error "Setting umask symbolically is not yet implemented")))
+ (set-default-file-modes (- #o777 (car args)))
(eshell-print
- "Warning: umask changed for all new files created by Emacs.\n"))
+ "Warning: umask changed for all new files created by Emacs.\n")))
nil))
+(put 'eshell/umask 'eshell-no-numeric-conversions t)
+
(provide 'em-basic)
;; Local Variables:
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index b79475f6e07..f4c1302629b 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -311,18 +311,24 @@ to writing a completion function."
(describe-prefix-bindings)
(call-interactively 'pcomplete-help)))
+(defun eshell--pcomplete-insert-tab ()
+ (if (not pcomplete-allow-modifications)
+ (throw 'pcompleted nil)
+ (insert-and-inherit "\t")
+ (throw 'pcompleted t)))
+
(defun eshell-complete-parse-arguments ()
"Parse the command line arguments for `pcomplete-argument'."
(when (and eshell-no-completion-during-jobs
(eshell-interactive-process-p))
- (insert-and-inherit "\t")
- (throw 'pcompleted t))
+ (eshell--pcomplete-insert-tab))
(let ((end (point-marker))
(begin (save-excursion (eshell-bol) (point)))
(posns (list t))
args delim)
- (when (memq this-command '(pcomplete-expand
- pcomplete-expand-and-complete))
+ (when (and pcomplete-allow-modifications
+ (memq this-command '(pcomplete-expand
+ pcomplete-expand-and-complete)))
(run-hook-with-args 'eshell-expand-input-functions begin end)
(if (= begin end)
(end-of-line))
@@ -335,14 +341,11 @@ to writing a completion function."
(setq begin (1+ (cadr delim))
args (eshell-parse-arguments begin end)))
((eq (car delim) ?\()
- (eshell-complete-lisp-symbol)
- (throw 'pcompleted t))
+ (throw 'pcompleted (elisp-completion-at-point)))
(t
- (insert-and-inherit "\t")
- (throw 'pcompleted t))))
+ (eshell--pcomplete-insert-tab))))
(when (get-text-property (1- end) 'comment)
- (insert-and-inherit "\t")
- (throw 'pcompleted t))
+ (eshell--pcomplete-insert-tab))
(let ((pos begin))
(while (< pos end)
(if (get-text-property pos 'arg-begin)
diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el
index eb5b3bfe1df..3db1dea5955 100644
--- a/lisp/eshell/em-extpipe.el
+++ b/lisp/eshell/em-extpipe.el
@@ -49,6 +49,19 @@
(add-hook 'eshell-pre-rewrite-command-hook
#'eshell-rewrite-external-pipeline -20 t))
+(defmacro em-extpipe--or-with-catch (&rest disjuncts)
+ "Evaluate DISJUNCTS like `or' but catch `eshell-incomplete'.
+
+If `eshell-incomplete' is thrown during the evaluation of a
+disjunct, that disjunct yields nil."
+ (let ((result (gensym)))
+ `(let (,result)
+ (or ,@(cl-loop for disjunct in disjuncts collect
+ `(if (catch 'eshell-incomplete
+ (ignore (setq ,result ,disjunct)))
+ nil
+ ,result))))))
+
(defun eshell-parse-external-pipeline ()
"Parse a pipeline intended for execution by the external shell.
@@ -105,10 +118,11 @@ as though it were Eshell syntax."
(if (re-search-forward pat next t)
(throw 'found (match-beginning 1))
(goto-char next)
- (while (or (eshell-parse-lisp-argument)
- (eshell-parse-backslash)
- (eshell-parse-double-quote)
- (eshell-parse-literal-quote)))
+ (while (em-extpipe--or-with-catch
+ (eshell-parse-lisp-argument)
+ (eshell-parse-backslash)
+ (eshell-parse-double-quote)
+ (eshell-parse-literal-quote)))
;; Guard against an infinite loop if none of
;; the parsers moved us forward.
(unless (or (> (point) next) (eobp))
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index 16abf044899..a18127a547a 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -341,7 +341,7 @@ unless a different file is specified on the command line.")
(error "No history"))
(let (length file)
(when (and args (string-match "^[0-9]+$" (car args)))
- (setq length (min (eshell-convert (car args))
+ (setq length (min (string-to-number (car args))
(ring-length eshell-history-ring))
args (cdr args)))
(and length
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index 846f3d5e290..874591d2501 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -100,15 +100,14 @@ faster and conserves more memory."
:type 'boolean)
(defface eshell-ls-directory
- '((((class color) (background light)) (:foreground "Blue" :weight bold))
- (((class color) (background dark)) (:foreground "SkyBlue" :weight bold))
- (t (:weight bold)))
- "The face used for highlighting directories.")
+ '((t (:inherit font-lock-function-name-face)))
+ "The face used for highlighting directories."
+ :version "29.1")
(defface eshell-ls-symlink
- '((((class color) (background light)) (:foreground "Dark Cyan" :weight bold))
- (((class color) (background dark)) (:foreground "Cyan" :weight bold)))
- "The face used for highlighting symbolic links.")
+ '((t (:inherit font-lock-keyword-face)))
+ "The face used for highlighting symbolic links."
+ :version "29.1")
(defface eshell-ls-executable
'((((class color) (background light)) (:foreground "ForestGreen" :weight bold))
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index fc023f23ce2..98902fc6f23 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -163,7 +163,7 @@ by the user on the command line."
(defcustom eshell-explicit-command-char ?*
"If this char occurs before a command name, call it externally.
-That is, although `vi' may be an alias, `\vi' will always call the
+That is, although `vi' may be an alias, `*vi' will always call the
external version."
:type 'character
:group 'eshell-ext)
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index 788404fc43a..8089d4d74b6 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -151,49 +151,52 @@ Otherwise, evaluates FORM with no error handling."
(defun eshell-find-delimiter
(open close &optional bound reverse-p backslash-p)
"From point, find the CLOSE delimiter corresponding to OPEN.
-The matching is bounded by BOUND.
-If REVERSE-P is non-nil, process the region backwards.
-If BACKSLASH-P is non-nil, and OPEN and CLOSE are the same character,
-then quoting is done by a backslash, rather than a doubled delimiter."
+The matching is bounded by BOUND. If REVERSE-P is non-nil,
+process the region backwards.
+
+If BACKSLASH-P is non-nil, or OPEN and CLOSE are different
+characters, then a backslash can be used to escape a delimiter
+(or another backslash). Otherwise, the delimiter is escaped by
+doubling it up."
(save-excursion
(let ((depth 1)
(bound (or bound (point-max))))
- (if (if reverse-p
- (eq (char-before) close)
- (eq (char-after) open))
- (forward-char (if reverse-p -1 1)))
+ (when (if reverse-p
+ (eq (char-before) close)
+ (eq (char-after) open))
+ (forward-char (if reverse-p -1 1)))
(while (and (> depth 0)
- (funcall (if reverse-p '> '<) (point) bound))
- (let ((c (if reverse-p (char-before) (char-after))) nc)
+ (funcall (if reverse-p #'> #'<) (point) bound))
+ (let ((c (if reverse-p (char-before) (char-after))))
(cond ((and (not reverse-p)
(or (not (eq open close))
backslash-p)
(eq c ?\\)
- (setq nc (char-after (1+ (point))))
- (or (eq nc open) (eq nc close)))
+ (memq (char-after (1+ (point)))
+ (list open close ?\\)))
(forward-char 1))
((and reverse-p
(or (not (eq open close))
backslash-p)
- (or (eq c open) (eq c close))
- (eq (char-before (1- (point)))
- ?\\))
+ (eq (char-before (1- (point))) ?\\)
+ (memq c (list open close ?\\)))
(forward-char -1))
((eq open close)
- (if (eq c open)
- (if (and (not backslash-p)
- (eq (if reverse-p
- (char-before (1- (point)))
- (char-after (1+ (point)))) open))
- (forward-char (if reverse-p -1 1))
- (setq depth (1- depth)))))
+ (when (eq c open)
+ (if (and (not backslash-p)
+ (eq (if reverse-p
+ (char-before (1- (point)))
+ (char-after (1+ (point))))
+ open))
+ (forward-char (if reverse-p -1 1))
+ (setq depth (1- depth)))))
((= c open)
(setq depth (+ depth (if reverse-p -1 1))))
((= c close)
(setq depth (+ depth (if reverse-p 1 -1))))))
(forward-char (if reverse-p -1 1)))
- (if (= depth 0)
- (if reverse-p (point) (1- (point)))))))
+ (when (= depth 0)
+ (if reverse-p (point) (1- (point)))))))
(defun eshell-convert (string)
"Convert STRING into a more native looking Lisp object."
diff --git a/lisp/faces.el b/lisp/faces.el
index 30f8483159a..b4e1f03eef6 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -46,7 +46,8 @@ the terminal-initialization file to be loaded."
("vt320" . "vt200")
("vt400" . "vt200")
("vt420" . "vt200")
- ("alacritty" . "xterm"))
+ ("alacritty" . "xterm")
+ ("foot" . "xterm"))
"Alist of terminal type aliases.
Entries are of the form (TYPE . ALIAS), where both elements are strings.
This means to treat a terminal of type TYPE as if it were of type ALIAS."
@@ -2656,8 +2657,9 @@ non-nil."
:background "grey75" :foreground "black")
(t
:inverse-video t))
- "Face for the mode lines (for the selected window) as well as header lines.
-See `mode-line-display' for the face used on mode lines."
+ "Face for the mode lines as well as header lines.
+See `mode-line-active' and `mode-line-inactive' for the faces
+used on mode lines."
:version "21.1"
:group 'mode-line-faces
:group 'basic-faces)
diff --git a/lisp/ffap.el b/lisp/ffap.el
index b5d2a02cd1d..30a9577d38f 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -79,7 +79,7 @@
;; (setq ffap-shell-prompt-regexp nil) ; disable shell prompt stripping
;; (setq ffap-gopher-regexp nil) ; disable gopher bookmark matching
;;
-;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URL's.
+;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URLs.
;; For a hairier `ffap-url-fetcher', try ffap-url.el (same ftp site).
;; Also, you can add `ffap-menu-rescan' to various hooks to fontify
;; the file and URL references within a buffer.
@@ -282,7 +282,7 @@ For a fancy alternative, get `ffap-url.el'."
:risky t)
(defcustom ffap-next-regexp
- ;; If you want ffap-next to find URL's only, try this:
+ ;; If you want ffap-next to find URLs only, try this:
;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp)
;; (concat "\\<" (substring ffap-url-regexp 2))))
;;
@@ -315,7 +315,7 @@ disable ffap most of the time."
;;; Find Next Thing in buffer (`ffap-next'):
;;
-;; Original ffap-next-url (URL's only) from RPECK 30 Mar 1995. Since
+;; Original ffap-next-url (URLs only) from RPECK 30 Mar 1995. Since
;; then, broke it up into ffap-next-guess (noninteractive) and
;; ffap-next (a command). It now work on files as well as url's.
@@ -363,7 +363,7 @@ Actual search is done by the function `ffap-next-guess'."
(sit-for 0) ; display point movement
(find-file-at-point (ffap-prompter guess)))
(goto-char pt) ; restore point
- (message "No %sfiles or URL's found"
+ (message "No %sfiles or URLs found"
(if wrap "" "more ")))))
(defun ffap-next-url (&optional back wrap)
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 319bfe05655..0ae9fb076eb 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -722,14 +722,18 @@ will not be changed."
(copy-tree connection-local-variables-alist)))
(hack-local-variables-apply)))
+(defvar connection-local-default-application 'tramp
+ "Default application in connection-local functions, a symbol.
+This variable must not be changed globally.")
+
(defsubst connection-local-criteria-for-default-directory (&optional application)
"Return a connection-local criteria, which represents `default-directory'.
-If APPLICATION is nil, the symbol `tramp' is used."
+If APPLICATION is nil, `connection-local-default-application' is used."
(when (file-remote-p default-directory)
- `(:application ,(or application 'tramp)
- :protocol ,(file-remote-p default-directory 'method)
- :user ,(file-remote-p default-directory 'user)
- :machine ,(file-remote-p default-directory 'host))))
+ `(:application ,(or application connection-local-default-application)
+ :protocol ,(file-remote-p default-directory 'method)
+ :user ,(file-remote-p default-directory 'user)
+ :machine ,(file-remote-p default-directory 'host))))
;;;###autoload
(defmacro with-connection-local-variables (&rest body)
diff --git a/lisp/files.el b/lisp/files.el
index a0bc5bf2626..2aa6c9dedc6 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5091,7 +5091,11 @@ On most systems, this will be true:
;; If there's nothing left to peel off, we're at the root and
;; we can stop.
(when (and dir (equal dir filename))
- (push "" components)
+ (push (if (equal dir "") ""
+ ;; On Windows, the first component might be "c:" or
+ ;; the like.
+ (substring dir 0 -1))
+ components)
(setq filename nil))))
components))
diff --git a/lisp/finder.el b/lisp/finder.el
index a40f8c64f24..899e8292962 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -367,7 +367,7 @@ not `finder-known-keywords'."
"Display FILE's commentary section.
FILE should be in a form suitable for passing to `locate-library'."
;; FIXME: Merge this function into `describe-package', which is
- ;; strictly better as it has links to URL's and is in a proper help
+ ;; strictly better as it has links to URLs and is in a proper help
;; buffer with navigation forward and backward, etc.
(interactive
(list
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index d8a1fe399b6..5034c98d26e 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -208,6 +208,7 @@
(require 'syntax)
(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x))
;; Define core `font-lock' group.
(defgroup font-lock '((jit-lock custom-group))
@@ -279,6 +280,47 @@ decoration for buffers in C++ mode, and level 1 decoration otherwise."
(integer :tag "level" 1)))))
:group 'font-lock)
+(defcustom font-lock-ignore nil
+ "Rules to selectively disable fontifications due to `font-lock-keywords'.
+If non-nil, the value should be a list of condition sets of the form
+
+ (SYMBOL CONDITION ...)
+
+where:
+
+ - SYMBOL is a symbol, usually a major or minor mode. The subsequent
+ CONDITIONs apply if SYMBOL is bound as variable and its value is non-nil.
+ If SYMBOL is a symbol of a mode, that means the buffer has that mode
+ enabled (for major modes, it means the buffer's major mode is derived
+ from SYMBOL's mode).
+
+ - Each CONDITION can be one of the following:
+ - A symbol, typically a face. It matches any element of
+ `font-lock-keywords' that references the symbol. The symbol is
+ interpreted as a glob pattern; in particular, `*' matches
+ everything, `?' matches any single character, and `[abcd]'
+ matches one character from the set.
+ - A string. It matches any element of `font-lock-keywords' whose
+ MATCHER is a regexp that matches the string. This can be used to
+ disable fontification of a particular programming keyword.
+ - A form (pred FUNCTION). It matches an element of `font-lock-keywords'
+ if FUNCTION, when called with the element as the argument, returns
+ non-nil.
+ - A form (not CONDITION). It matches if CONDITION doesn't.
+ - A form (and CONDITION ...). It matches if all the provided
+ CONDITIONs match.
+ - A form (or CONDITION ...). It matches if at least one of the
+ provided CONDITIONs matches.
+ - A form (except CONDITIONs ...). This can be used only at top level
+ or inside an `or' clause. It undoes the effect of previous
+ matching CONDITIONs on the same level.
+
+In each buffer, fontifications due to the elements of `font-lock-keywords'
+that match at least one applicable CONDITION are disabled."
+ :type '(alist :key-type symbol :value-type sexp)
+ :group 'font-lock
+ :version "29.1")
+
(defcustom font-lock-verbose nil
"If non-nil, means show status messages for buffer fontification.
If a number, only buffers greater than this size have fontification messages."
@@ -1810,9 +1852,8 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords are used for
(error "Font-lock trying to use keywords before setting them up"))
(if (eq (car-safe keywords) t)
keywords
- (setq keywords
- (cons t (cons keywords
- (mapcar #'font-lock-compile-keyword keywords))))
+ (let ((compiled (mapcar #'font-lock-compile-keyword keywords)))
+ (setq keywords `(t ,keywords ,@(font-lock--filter-keywords compiled))))
(if (and (not syntactic-keywords)
(let ((beg-function (with-no-warnings syntax-begin-function)))
(or (eq beg-function #'beginning-of-defun)
@@ -1883,6 +1924,50 @@ A LEVEL of nil is equal to a LEVEL of 0, a LEVEL of t is equal to
(t
(car keywords))))
+(defun font-lock--match-keyword (rule keyword)
+ "Return non-nil if font-lock KEYWORD matches RULE.
+See `font-lock-ignore' for the possible rules."
+ (pcase-exhaustive rule
+ ('* t)
+ ((pred symbolp)
+ (let ((regexp (when (string-match-p "[*?]" (symbol-name rule))
+ (wildcard-to-regexp (symbol-name rule)))))
+ (named-let search ((obj keyword))
+ (cond
+ ((consp obj) (or (search (car obj)) (search (cdr obj))))
+ ((not regexp) (eq rule obj))
+ ((symbolp obj) (string-match-p regexp (symbol-name obj)))))))
+ ((pred stringp) (when (stringp (car keyword))
+ (string-match-p (concat "\\`\\(?:" (car keyword) "\\)")
+ rule)))
+ (`(or . ,rules) (let ((match nil))
+ (while rules
+ (pcase-exhaustive (pop rules)
+ (`(except ,rule)
+ (when match
+ (setq match (not (font-lock--match-keyword rule keyword)))))
+ (rule
+ (unless match
+ (setq match (font-lock--match-keyword rule keyword))))))
+ match))
+ (`(not ,rule) (not (font-lock--match-keyword rule keyword)))
+ (`(and . ,rules) (seq-every-p (lambda (rule)
+ (font-lock--match-keyword rule keyword))
+ rules))
+ (`(pred ,fun) (funcall fun keyword))))
+
+(defun font-lock--filter-keywords (keywords)
+ "Filter a list of KEYWORDS using `font-lock-ignore'."
+ (if-let ((rules (mapcan (pcase-lambda (`(,mode . ,rules))
+ (when (or (and (boundp mode) mode)
+ (derived-mode-p mode))
+ (copy-sequence rules)))
+ font-lock-ignore)))
+ (seq-filter (lambda (keyword) (not (font-lock--match-keyword
+ `(or ,@rules) keyword)))
+ keywords)
+ keywords))
+
(defun font-lock-refresh-defaults ()
"Restart fontification in current buffer after recomputing from defaults.
Recompute fontification variables using `font-lock-defaults' and
diff --git a/lisp/frame.el b/lisp/frame.el
index b681a971aa3..7b19b8b5d32 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -2433,6 +2433,70 @@ monitors."
,(display-mm-height display)))
(frames . ,(frames-on-display-list display)))))))))
+(declare-function x-device-class (name) "x-win.el")
+(declare-function pgtk-device-class (name) "pgtk-win.el")
+
+(defun device-class (frame name)
+ "Return the class of the device NAME for an event generated on FRAME.
+NAME is a string that can be the value of `last-event-device', or
+nil. FRAME is a window system frame, typically the value of
+`last-event-frame' when `last-event-device' was set. On some
+window systems, it can also be a display name or a terminal.
+
+The class of a device is one of the following symbols:
+
+ `core-keyboard' means the device is a keyboard-like device, but
+ any other characteristics are unknown.
+
+ `core-pointer' means the device is a pointing device, but any
+ other characteristics are unknown.
+
+ `mouse' means the device is a computer mouse.
+
+ `trackpoint' means the device is a joystick or trackpoint.
+
+ `eraser' means the device is an eraser, which is typically the
+ other end of a stylus on a graphics tablet.
+
+ `pen' means the device is a stylus or some other similar
+ device.
+
+ `puck' means the device is a device similar to a mouse, but
+ reports absolute coordinates.
+
+ `power-button' means the device is a power button, volume
+ button, or some similar control.
+
+ `keyboard' means the device is a keyboard.
+
+ `touchscreen' means the device is a touchscreen.
+
+ `pad' means the device is a collection of buttons and rings and
+ strips commonly found in drawing tablets.
+
+ `touchpad' means the device is an indirect touch device, such
+ as a touchpad.
+
+ `piano' means the device is a piano, or some other kind of
+ musical instrument.
+
+ `test' means the device is used by the XTEST extension to
+ report input.
+
+It can also be nil, which means the class of the device could not
+be determined. Individual window systems may also return other
+symbols."
+ (let ((frame-type (framep-on-display frame)))
+ (cond ((eq frame-type 'x)
+ (x-device-class name))
+ ((eq frame-type 'pgtk)
+ (pgtk-device-class name))
+ (t (cond
+ ((string= name "Virtual core pointer")
+ 'core-pointer)
+ ((string= name "Virtual core keyboard")
+ 'core-keyboard))))))
+
;;;; Frame geometry values
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index f38f6f4ee2b..f6ae028a104 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1593,9 +1593,10 @@ this is a reply."
(nnheader-set-temp-buffer " *acc*")
(setq message-options (with-current-buffer cur message-options))
(insert-buffer-substring cur)
+ (restore-buffer-modified-p nil)
(run-hooks 'gnus-gcc-pre-body-encode-hook)
;; Avoid re-doing things like GPG-encoding secret parts.
- (if (not encoded-cache)
+ (if (or (buffer-modified-p) (not encoded-cache))
(message-encode-message-body)
(erase-buffer)
(insert encoded-cache))
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index 4ca873eeec9..6c70257f42f 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -349,6 +349,41 @@ This variable can also be set per-server."
:version "28.1"
:type 'boolean)
+(defcustom gnus-search-mu-program "mu"
+ "Name of the mu search executable.
+This can also be set per-server."
+ :version "29.1"
+ :type 'string)
+
+(defcustom gnus-search-mu-switches nil
+ "A list of strings, to be given as additional arguments to mu.
+Note that this should be a list. I.e., do NOT use the following:
+ (setq gnus-search-mu-switches \"-u -r\")
+Instead, use this:
+ (setq gnus-search-mu-switches \\='(\"-u\" \"-r\"))
+This can also be set per-server."
+ :version "29.1"
+ :type '(repeat string))
+
+(defcustom gnus-search-mu-remove-prefix (expand-file-name "~/Mail/")
+ "A prefix to remove from the mu results to get a group name.
+Usually this will be set to the path to your mail directory. This
+can also be set per-server."
+ :version "29.1"
+ :type 'directory)
+
+(defcustom gnus-search-mu-config-directory (expand-file-name "~/.cache/mu")
+ "Configuration directory for mu.
+This can also be set per-server."
+ :version "29.1"
+ :type 'file)
+
+(defcustom gnus-search-mu-raw-queries-p nil
+ "If t, all mu engines will only accept raw search query strings.
+This can also be set per-server."
+ :version "29.1"
+ :type 'boolean)
+
;; Options for search language parsing.
(defcustom gnus-search-expandable-keys
@@ -903,6 +938,18 @@ quirks.")
(raw-queries-p
:initform (symbol-value 'gnus-search-notmuch-raw-queries-p))))
+(defclass gnus-search-mu (gnus-search-indexed)
+ ((program
+ :initform (symbol-value 'gnus-search-mu-program))
+ (remove-prefix
+ :initform (symbol-value 'gnus-search-mu-remove-prefix))
+ (switches
+ :initform (symbol-value 'gnus-search-mu-switches))
+ (config-directory
+ :initform (symbol-value 'gnus-search-mu-config-directory))
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-mu-raw-queries-p))))
+
(define-obsolete-variable-alias 'nnir-method-default-engines
'gnus-search-default-engines "28.1")
@@ -1849,6 +1896,101 @@ Assume \"size\" key is equal to \"larger\"."
(when (alist-get 'thread query) (list "-t"))
(list qstring))))
+;;; Mu interface
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mu)
+ (expr list))
+ (cl-case (car expr)
+ (recipient (setf (car expr) 'recip))
+ (address (setf (car expr) 'contact))
+ (id (setf (car expr) 'msgid))
+ (attachment (setf (car expr) 'file)))
+ (cl-flet ()
+ (cond
+ ((consp (car expr))
+ (format "(%s)" (gnus-search-transform engine expr)))
+ ;; Explicitly leave out 'date as gnus-search will encode it
+ ;; first; it is handled later
+ ((memq (car expr) '(cc c bcc h from f to t subject s body b
+ maildir m msgid i prio p flag g d
+ size z embed e file j mime y tag x
+ list v))
+ (format "%s:%s" (car expr)
+ (if (string-match "\\`\\*" (cdr expr))
+ (replace-match "" nil nil (cdr expr))
+ (cdr expr))))
+ ((eq (car expr) 'mark)
+ (format "flag:%s" (gnus-search-mu-handle-flag (cdr expr))))
+ ((eq (car expr) 'date)
+ (format "date:%s" (gnus-search-mu-handle-date (cdr expr))))
+ ((eq (car expr) 'before)
+ (format "date:..%s" (gnus-search-mu-handle-date (cdr expr))))
+ ((eq (car expr) 'since)
+ (format "date:%s.." (gnus-search-mu-handle-date (cdr expr))))
+ (t (ignore-errors (cl-call-next-method))))))
+
+(defun gnus-search-mu-handle-date (date)
+ (if (stringp date)
+ date
+ (pcase date
+ (`(nil ,m nil)
+ (nth (1- m) gnus-english-month-names))
+ (`(nil nil ,y)
+ (number-to-string y))
+ ;; mu prefers ISO date YYYY-MM-DD HH:MM:SS
+ (`(,d ,m nil)
+ (let* ((ct (decode-time))
+ (cm (decoded-time-month ct))
+ (cy (decoded-time-year ct))
+ (y (if (> cm m)
+ cy
+ (1- cy))))
+ (format "%d-%02d-%02d" y m d)))
+ (`(nil ,m ,y)
+ (format "%d-%02d" y m))
+ (`(,d ,m ,y)
+ (format "%d-%02d-%02d" y m d)))))
+
+(defun gnus-search-mu-handle-flag (flag)
+ ;; Only change what doesn't match
+ (cond ((string= flag "flag")
+ "flagged")
+ ((string= flag "read")
+ "seen")
+ (t
+ flag)))
+
+(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-mu))
+ (prog1
+ (let ((bol (line-beginning-position))
+ (eol (line-end-position)))
+ (list (buffer-substring-no-properties bol eol)
+ 100))
+ (move-beginning-of-line 2)))
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mu)
+ (qstring string)
+ query &optional groups)
+ (let ((limit (alist-get 'limit query))
+ (thread (alist-get 'thread query)))
+ (with-slots (switches config-directory) engine
+ `("find" ; command must come first
+ "--nocolor" ; mu will always give coloured output otherwise
+ ,(format "--muhome=%s" config-directory)
+ ,@switches
+ ,(if thread "-r" "")
+ ,(if limit (format "--maxnum=%d" limit) "")
+ ,qstring
+ ,@(if groups
+ `("and" "("
+ ,@(nbutlast (mapcan (lambda (x)
+ (list (concat "maildir:/" x) "or"))
+ groups))
+ ")")
+ "")
+ "--format=plain"
+ "--fields=l"))))
+
;;; Find-grep interface
(cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep)
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 769ad6d9eb1..62efacfd6e2 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -8663,7 +8663,7 @@ these articles."
(when matching-subject
(gnus-summary-limit-include-matching-articles
"subject"
- matching-subject)
+ (regexp-quote matching-subject))
;; Each of the previous two limit calls push a limit onto
;; the limit stack. Presumably we want to think of the
;; thread and its associated subject matches as a single
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index 5d0c0e2654b..320bc9c3b0e 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -413,7 +413,7 @@ the `mail-source-keyword-map' variable."
(let* ((type (pop source))
(defaults (cdr (assq type mail-source-keyword-map)))
(search '(:max 1))
- found default value keyword user-auth pass-auth) ;; auth-info
+ found default keyword user-auth pass-auth) ;; auth-info
;; append to the search the useful info from the source and the defaults:
;; user, host, and port
@@ -440,22 +440,22 @@ the `mail-source-keyword-map' variable."
;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL
;; using `mail-source-value' to evaluate the plist value
(set (mail-source-strip-keyword (setq keyword (car default)))
- ;; note the following reasons for this structure:
+ ;; Note the following reasons for this structure:
;; 1) the auth-sources user and password override everything
;; 2) it avoids macros, so it's cleaner
;; 3) it falls through to the mail-sources and then default values
(cond
((and
- (eq keyword :user)
- (setq user-auth
- (plist-get
- ;; cache the search result in `found'
- (or found
- (setq found (nth 0 (apply #'auth-source-search
- search))))
- :user)))
+ (eq keyword :user)
+ (setq user-auth
+ (plist-get
+ ;; cache the search result in `found'
+ (or found
+ (setq found (nth 0 (apply #'auth-source-search
+ search))))
+ :user)))
user-auth)
- ((and ; cf. 'auth-source-pick-first-password'
+ ((and ; cf. 'auth-source-pick-first-password'
(eq keyword :password)
(setq pass-auth
(plist-get
@@ -468,9 +468,8 @@ the `mail-source-keyword-map' variable."
(if (functionp pass-auth)
(setq pass-auth (funcall pass-auth))
pass-auth))
- (t (if (setq value (plist-get source keyword))
- (mail-source-value value)
- (mail-source-value (cadr default)))))))))
+ (t (mail-source-value (or (plist-get source keyword)
+ (cadr default)))))))))
(eval-and-compile
(defun mail-source-bind-common-1 ()
@@ -1066,9 +1065,7 @@ This only works when `display-time' is enabled."
(let ((from (format "%s:%s:%s" server user port))
(found 0)
(buf (generate-new-buffer " *imap source*"))
- (mail-source-string (format "imap:%s:%s" server mailbox))
- (imap-shell-program (or (list program) imap-shell-program))
- remove)
+ (imap-shell-program (or (list program) imap-shell-program)))
(if (and (imap-open server port stream authentication buf)
(imap-authenticate
user (or (cdr (assoc from mail-source-password-cache))
@@ -1077,8 +1074,10 @@ This only works when `display-time' is enabled."
(let ((mailbox-list (if (listp mailbox) mailbox (list mailbox))))
(dolist (mailbox mailbox-list)
(when (imap-mailbox-select mailbox nil buf)
- (let ((coding-system-for-write mail-source-imap-file-coding-system)
- str)
+ (let ((coding-system-for-write
+ mail-source-imap-file-coding-system)
+ (mail-source-string (format "imap:%s:%s" server mailbox))
+ str remove)
(message "Fetching from %s..." mailbox)
(with-temp-file mail-source-crash-box
;; Avoid converting 8-bit chars from inserted strings to
diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el
index d6289f13395..89ddd608979 100644
--- a/lisp/gnus/nnselect.el
+++ b/lisp/gnus/nnselect.el
@@ -110,6 +110,7 @@
selection)))
(make-obsolete 'nnselect-group-server 'gnus-group-server "28.1")
+(make-obsolete 'nnselect-run 'nnselect-generate-artlist "29.1")
;; Data type article list.
@@ -231,11 +232,6 @@ as `(keyfunc member)' and the corresponding element is just
`(gnus-group-prefixed-name
(gnus-group-short-name ,group) '(nnselect "nnselect")))
-(defmacro nnselect-get-artlist (group)
- "Retrieve the list of articles for GROUP."
- `(when (gnus-nnselect-group-p ,group)
- (nnselect-uncompress-artlist
- (gnus-group-get-parameter ,group 'nnselect-artlist t))))
(defmacro nnselect-add-novitem (novitem)
"Add NOVITEM to the list of headers."
@@ -271,6 +267,63 @@ If this variable is nil, or if the provided function returns nil,
:version "28.1"
:type '(repeat function))
+(defun nnselect-generate-artlist (group &optional specs)
+ "Generate the artlist for GROUP using SPECS.
+SPECS should be an alist including an 'nnselect-function and an
+'nnselect-args. The former applied to the latter should create
+the artlist. If SPECS is nil retrieve the specs from the group
+parameters."
+ (let* ((specs
+ (or specs (gnus-group-get-parameter group 'nnselect-specs t)))
+ (function (alist-get 'nnselect-function specs))
+ (args (alist-get 'nnselect-args specs)))
+ (condition-case-unless-debug err
+ (funcall function args)
+ ;; Don't swallow gnus-search errors; the user should be made
+ ;; aware of them.
+ (gnus-search-error
+ (signal (car err) (cdr err)))
+ (error
+ (gnus-error
+ 3
+ "nnselect-generate-artlist: %s on %s gave error %s" function args err)
+ []))))
+
+(defmacro nnselect-get-artlist (group)
+ "Get the list of articles for GROUP.
+If the group parameter 'nnselect-get-artlist-override-function is
+non-nil call this function with argument GROUP to get the
+artlist; if the group parameter 'nnselect-always-regenerate is
+non-nil, regenerate the artlist; otherwise retrieve the artlist
+directly from the group parameters."
+ `(when (gnus-nnselect-group-p ,group)
+ (let ((override (gnus-group-get-parameter
+ ,group
+ 'nnselect-get-artlist-override-function)))
+ (cond
+ (override (funcall override ,group))
+ ((gnus-group-get-parameter ,group 'nnselect-always-regenerate)
+ (nnselect-generate-artlist ,group))
+ (t
+ (nnselect-uncompress-artlist
+ (gnus-group-get-parameter ,group 'nnselect-artlist t)))))))
+
+(defmacro nnselect-store-artlist (group artlist)
+ "Store the ARTLIST for GROUP.
+If the group parameter 'nnselect-store-artlist-override-function
+is non-nil call this function on GROUP and ARTLIST; if the group
+parameter 'nnselect-always-regenerate is non-nil don't store the
+artlist; otherwise store the ARTLIST in the group parameters."
+ `(let ((override (gnus-group-get-parameter
+ ,group
+ 'nnselect-store-artlist-override-function)))
+ (cond
+ (override (funcall override ,group ,artlist))
+ ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) t)
+ (t
+ (gnus-group-set-parameter ,group 'nnselect-artlist
+ (nnselect-compress-artlist ,artlist))))))
+
;; Gnus backend interface functions.
(deffoo nnselect-open-server (server &optional definitions)
@@ -296,11 +349,8 @@ If this variable is nil, or if the provided function returns nil,
;; Check for cached select result or run the selection and cache
;; the result.
(unless nnselect-artlist
- (gnus-group-set-parameter
- group 'nnselect-artlist
- (nnselect-compress-artlist (setq nnselect-artlist
- (nnselect-run
- (gnus-group-get-parameter group 'nnselect-specs t)))))
+ (nnselect-store-artlist group
+ (setq nnselect-artlist (nnselect-generate-artlist group)))
(nnselect-request-update-info
group (or info (gnus-get-info group))))
(if (zerop (setq length (nnselect-artlist-length nnselect-artlist)))
@@ -338,6 +388,7 @@ If this variable is nil, or if the provided function returns nil,
(gnus-group-find-parameter artgroup
'gnus-fetch-old-headers t))
fetch-old)))
+ (gnus-request-group artgroup)
(erase-buffer)
(pcase (setq gnus-headers-retrieved-by
(or
@@ -671,10 +722,7 @@ If this variable is nil, or if the provided function returns nil,
(append (sort old-arts #'<)
(number-sequence first last))
nil t))
- (gnus-group-set-parameter
- group
- 'nnselect-artlist
- (nnselect-compress-artlist gnus-newsgroup-selection))
+ (nnselect-store-artlist group gnus-newsgroup-selection)
(when (>= last first)
(let (new-marks)
(pcase-dolist (`(,artgroup . ,artids)
@@ -721,6 +769,7 @@ If this variable is nil, or if the provided function returns nil,
(message "Creating nnselect group %s" group)
(let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect")))
(specs (assq 'nnselect-specs args))
+ (otherargs (assq-delete-all 'nnselect-specs args))
(function-spec
(or (alist-get 'nnselect-function specs)
(intern (completing-read "Function: " obarray #'functionp))))
@@ -730,10 +779,12 @@ If this variable is nil, or if the provided function returns nil,
(nnselect-specs (list (cons 'nnselect-function function-spec)
(cons 'nnselect-args args-spec))))
(gnus-group-set-parameter group 'nnselect-specs nnselect-specs)
- (gnus-group-set-parameter
- group 'nnselect-artlist
- (nnselect-compress-artlist (or (alist-get 'nnselect-artlist args)
- (nnselect-run nnselect-specs))))
+ (dolist (arg otherargs)
+ (gnus-group-set-parameter group (car arg) (cdr arg)))
+ (nnselect-store-artlist
+ group
+ (or (alist-get 'nnselect-artlist args)
+ (nnselect-generate-artlist group nnselect-specs)))
(nnselect-request-update-info group (gnus-get-info group)))
t)
@@ -765,13 +816,10 @@ If this variable is nil, or if the provided function returns nil,
(deffoo nnselect-request-group-scan (group &optional _server _info)
(let* ((group (nnselect-add-prefix group))
- (artlist (nnselect-uncompress-artlist (nnselect-run
- (gnus-group-get-parameter group 'nnselect-specs t)))))
+ (artlist (nnselect-generate-artlist group)))
(gnus-set-active group (cons 1 (nnselect-artlist-length
artlist)))
- (gnus-group-set-parameter
- group 'nnselect-artlist
- (nnselect-compress-artlist artlist))))
+ (nnselect-store-artlist group artlist)))
;; Add any undefined required backend functions
@@ -786,20 +834,6 @@ If this variable is nil, or if the provided function returns nil,
(eq 'nnselect (car gnus-command-method))))
-(defun nnselect-run (specs)
- "Apply nnselect-function to nnselect-args from SPECS.
-Return an article list."
- (let ((func (alist-get 'nnselect-function specs))
- (args (alist-get 'nnselect-args specs)))
- (condition-case-unless-debug err
- (funcall func args)
- ;; Don't swallow gnus-search errors; the user should be made
- ;; aware of them.
- (gnus-search-error
- (signal (car err) (cdr err)))
- (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err)
- []))))
-
(defun nnselect-search-thread (header)
"Make an nnselect group containing the thread with article HEADER.
The current server will be searched. If the registry is
diff --git a/lisp/help.el b/lisp/help.el
index f1a617f8500..780f5daac73 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -621,7 +621,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
(enable-recursive-minibuffers t)
val)
(setq val (completing-read (format-prompt "Where is command" fn)
- obarray 'commandp t nil nil
+ obarray #'commandp t nil nil
(and fn (symbol-name fn))))
(list (unless (equal val "") (intern val))
current-prefix-arg)))
@@ -2147,7 +2147,10 @@ the suggested string to use instead. See
confusables ", ")
string))))
-(defun help-command-error-confusable-suggestions (data _context _signal)
+(defun help-command-error-confusable-suggestions (data context signal)
+ ;; Delegate most of the work to the original default value of
+ ;; `command-error-function' implemented in C.
+ (command-error-default-function data context signal)
(pcase data
(`(void-variable ,var)
(let ((suggestions (help-uni-confusable-suggestions
@@ -2156,8 +2159,12 @@ the suggested string to use instead. See
(princ (concat "\n " suggestions) t))))
(_ nil)))
-(add-function :after command-error-function
- #'help-command-error-confusable-suggestions)
+(when (eq command-error-function #'command-error-default-function)
+ ;; Override the default set in the C code.
+ ;; This is not done using `add-function' so as to loosen the bootstrap
+ ;; dependencies.
+ (setq command-error-function
+ #'help-command-error-confusable-suggestions))
(define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1")
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 8e60ddf6b07..e5ca6819f0d 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -102,7 +102,16 @@ This variable has no effect in Global Highlight Line mode.
For that, use `global-hl-line-sticky-flag'."
:type 'boolean
:version "22.1"
- :group 'hl-line)
+ :group 'hl-line
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (when (featurep 'hl-line)
+ (unless value
+ (let ((selected (window-buffer (selected-window))))
+ (dolist (buffer (buffer-list))
+ (unless (eq buffer selected)
+ (with-current-buffer buffer
+ (hl-line-unhighlight)))))))))
(defcustom global-hl-line-sticky-flag nil
"Non-nil means the Global HL-Line mode highlight appears in all windows.
@@ -125,8 +134,11 @@ This variable is expected to be made buffer-local by modes.")
(defvar hl-line-overlay-buffer nil
"Most recently visited buffer in which Hl-Line mode is enabled.")
-(defvar hl-line-overlay-priority -50
- "Priority used on the overlay used by hl-line.")
+(defcustom hl-line-overlay-priority -50
+ "Priority used on the overlay used by hl-line."
+ :type 'integer
+ :version "28.1"
+ :group 'hl-line)
;;;###autoload
(define-minor-mode hl-line-mode
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index b2af3f06a27..721f2f2bbd8 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -419,39 +419,31 @@ window configuration prior to the last `image-mode-fit-frame'
call."
(interactive (list nil t))
(let* ((buffer (current-buffer))
- (display (image-get-display-property))
- (size (image-display-size display))
(saved (frame-parameter frame 'image-mode-saved-params))
(window-configuration (current-window-configuration frame))
- (width (frame-width frame))
- (height (frame-height frame)))
+ (frame-width (frame-text-width frame))
+ (frame-height (frame-text-height frame)))
(with-selected-frame (or frame (selected-frame))
(if (and toggle saved
- (= (caar saved) width)
- (= (cdar saved) height))
+ (= (caar saved) frame-width)
+ (= (cdar saved) frame-height))
(progn
- (set-frame-width frame (car (nth 1 saved)))
- (set-frame-height frame (cdr (nth 1 saved)))
+ (set-frame-width frame (car (nth 1 saved)) nil t)
+ (set-frame-height frame (cdr (nth 1 saved)) nil t)
(set-window-configuration (nth 2 saved))
(set-frame-parameter frame 'image-mode-saved-params nil))
(delete-other-windows)
(switch-to-buffer buffer t t)
- (let* ((edges (window-inside-edges))
- (inner-width (- (nth 2 edges) (nth 0 edges)))
- (inner-height (- (nth 3 edges) (nth 1 edges))))
- (set-frame-width frame (+ (ceiling (car size))
- width (- inner-width)))
- (set-frame-height frame (+ (ceiling (cdr size))
- height (- inner-height)))
- ;; The frame size after the above `set-frame-*' calls may
- ;; differ from what we specified, due to window manager
- ;; interference. We have to call `frame-width' and
- ;; `frame-height' to get the actual results.
- (set-frame-parameter frame 'image-mode-saved-params
- (list (cons (frame-width)
- (frame-height))
- (cons width height)
- window-configuration)))))))
+ (fit-frame-to-buffer frame)
+ ;; The frame size after the above `set-frame-*' calls may
+ ;; differ from what we specified, due to window manager
+ ;; interference. We have to call `frame-width' and
+ ;; `frame-height' to get the actual results.
+ (set-frame-parameter frame 'image-mode-saved-params
+ (list (cons (frame-text-width frame)
+ (frame-text-height frame))
+ (cons frame-width frame-height)
+ window-configuration))))))
;;; Image Mode setup
@@ -625,6 +617,8 @@ image as text, when opening such images in `image-mode'."
(put 'image-mode 'mode-class 'special)
+(declare-function image-converter-initialize "image-converter.el")
+
;;;###autoload
(defun image-mode ()
"Major mode for image files.
@@ -650,7 +644,12 @@ Key bindings:
"Empty file"
"(New file)")
"Empty buffer"))
- (image-mode--display)))
+ (image-mode--display)
+ ;; Ensure that we recognize externally parsed image formats in
+ ;; commands like `n'.
+ (when image-use-external-converter
+ (require 'image-converter)
+ (image-converter-initialize))))
(defun image-mode--display ()
(if (not (image-get-display-property))
@@ -1197,8 +1196,9 @@ replacing the current Image mode buffer."
"Return an 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)))
+ (let* ((non-essential t) ; Do not block for remote buffers.
+ (buffers nil)
+ (dir (file-name-directory file)))
(cond
((and (boundp 'tar-superior-buffer)
tar-superior-buffer)
@@ -1213,6 +1213,8 @@ tar mode buffers."
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (and (derived-mode-p 'dired-mode)
+ (equal (file-remote-p dir)
+ (file-remote-p default-directory))
(equal (file-truename dir)
(file-truename default-directory)))
(push (cons 'dired (current-buffer)) buffers))))
diff --git a/lisp/image.el b/lisp/image.el
index ec4ee06eb14..1b684d5c57a 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -380,6 +380,7 @@ be determined."
"Determine the type of image file FILE from its name.
Value is a symbol specifying the image type, or nil if type cannot
be determined."
+ (declare (obsolete image-supported-file-p "29.1"))
(let (type first (case-fold-search t))
(catch 'found
(dolist (elem image-type-file-name-regexps first)
@@ -389,6 +390,20 @@ be determined."
;; If nothing seems to be supported, return first type that matched.
(or first (setq first type))))))))
+ ;;;###autoload
+(defun image-supported-file-p (file)
+ "Say whether Emacs has native support for displaying TYPE.
+The value is a symbol specifying the image type, or nil if type
+cannot be determined (or if Emacs doesn't have built-in support
+for the image type)."
+ (let ((case-fold-search t)
+ type)
+ (catch 'found
+ (dolist (elem image-type-file-name-regexps)
+ (when (and (string-match-p (car elem) file)
+ (image-type-available-p (setq type (cdr elem))))
+ (throw 'found type))))))
+
(declare-function image-convert-p "image-converter.el"
(source &optional image-format))
(declare-function image-convert "image-converter.el"
@@ -417,7 +432,7 @@ type if we can't otherwise guess it."
(require 'image-converter)
(image-convert-p source data-p))))
(or (image-type-from-file-header source)
- (image-type-from-file-name source)
+ (image-supported-file-p source)
(and image-use-external-converter
(progn
(require 'image-converter)
@@ -461,6 +476,7 @@ must be available."
(and auto
(or (eq auto t) (image-type-available-p type)))))
+(defvar image-convert-to-format)
;;;###autoload
(defun create-image (file-or-data &optional type data-p &rest props)
@@ -498,7 +514,7 @@ Image file names that are not absolute are searched for in the
(when (eq type 'image-convert)
(require 'image-converter)
(setq file-or-data (image-convert file-or-data data-format)
- type 'png
+ type (intern image-convert-to-format)
data-p t)))
(when (image-type-available-p type)
(let ((image
diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el
index 460ff16adb0..a339e95ab4a 100644
--- a/lisp/image/image-converter.el
+++ b/lisp/image/image-converter.el
@@ -46,6 +46,16 @@ formats that are to be supported: Only the suffixes that map to
:type 'symbol
:version "27.1")
+(defcustom image-convert-to-format "png"
+ "The image format to convert to.
+This should be a string like \"png\" or \"ppm\" or some
+other (preferrably lossless) format that Emacs understands
+natively. The converter chosen has to support the format, and if
+not, conversion will fail."
+ :group 'image
+ :version "29.1"
+ :type 'string)
+
(defvar image-converter-regexp nil
"A regexp that matches the file name suffixes that can be converted.")
@@ -58,15 +68,19 @@ formats that are to be supported: Only the suffixes that map to
(imagemagick :command "convert" :probe ("-list" "format")))
"List of supported image converters to try.")
+(defun image-converter-initialize ()
+ "Determine the external image converter to be used.
+This also determines which external formats we can parse."
+ (unless image-converter
+ (image-converter--find-converter)))
+
(defun image-convert-p (source &optional data-p)
"Return `image-convert' if SOURCE is an image that can be converted.
SOURCE can either be a file name or a string containing image
data. In the latter case, DATA-P should be non-nil. If DATA-P
is a string, it should be a MIME format string like
\"image/gif\"."
- ;; Find an installed image converter.
- (unless image-converter
- (image-converter--find-converter))
+ (image-converter-initialize)
;; When image-converter was customized
(when (and image-converter (not image-converter-regexp))
(when-let ((formats (image-converter--probe image-converter)))
@@ -85,7 +99,10 @@ is a string, it should be a MIME format string like
'image-convert))
(defun image-convert (image &optional image-format)
- "Convert IMAGE file to the PNG format.
+ "Convert IMAGE file to an image format Emacs understands.
+This will usually be \"png\", but this is controlled by the
+`image-convert-to-format' user option.
+
IMAGE can either be a file name or image data.
To pass in image data, IMAGE should a string containing the image
@@ -96,11 +113,9 @@ like \"image/webp\". For instance:
IMAGE can also be an image object as returned by `create-image'.
-This function converts the image to PNG, and the converted image
-data is returned as a string."
- ;; Find an installed image converter.
- (unless image-converter
- (image-converter--find-converter))
+This function converts the image the preferred format, and the
+converted image data is returned as a string."
+ (image-converter-initialize)
(unless image-converter
(error "No external image converters available"))
(when (and image-format
@@ -120,7 +135,9 @@ data is returned as a string."
(if (listp image)
;; Return an image object that's the same as we were passed,
;; but ignore the :type value.
- (apply #'create-image (buffer-string) 'png t
+ (apply #'create-image (buffer-string)
+ (intern image-convert-to-format)
+ t
(cl-loop for (key val) on (cdr image) by #'cddr
unless (eq key :type)
append (list key val)))
@@ -239,12 +256,15 @@ Only suffixes that map to `image-mode' are returned."
(list (format "%s:-"
(image-converter--mime-type
image-format))
- "png:-"))))
+ (concat image-convert-to-format
+ ":-")))))
;; SOURCE is a file name.
(apply #'call-process (car command)
nil t nil
(append (cdr command)
- (list (expand-file-name source) "png:-")))))
+ (list (expand-file-name source)
+ (concat image-convert-to-format
+ ":-"))))))
;; If the command failed, hopefully the buffer contains the
;; error message.
(buffer-string))))
@@ -262,14 +282,15 @@ Only suffixes that map to `image-mode' are returned."
(append
(cdr command)
(list "-i" "-"
- "-c:v" "png"
+ "-c:v" image-convert-to-format
"-f" "image2pipe" "-"))))
(apply #'call-process
(car command)
nil '(t nil) nil
(append (cdr command)
(list "-i" (expand-file-name source)
- "-c:v" "png" "-f" "image2pipe"
+ "-c:v" image-convert-to-format
+ "-f" "image2pipe"
"-")))))
"ffmpeg error when converting")))
diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el
index 10f8ce6efbd..b90c065461a 100644
--- a/lisp/international/iso-transl.el
+++ b/lisp/international/iso-transl.el
@@ -182,10 +182,10 @@
("o" . [?°])
("Oe" . [?œ])
("OE" . [?Œ])
- ("*u" . [?µ])
- ("u" . [?µ])
- ("*m" . [?µ])
- ("m" . [?µ])
+ ("*u" . [?μ])
+ ("u" . [?μ])
+ ("*m" . [?μ])
+ ("m" . [?μ])
("*x" . [?×])
("x" . [?×])
("*|" . [?¦])
diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el
index 6985f4f3efe..82eba1b5d51 100644
--- a/lisp/international/textsec.el
+++ b/lisp/international/textsec.el
@@ -231,6 +231,22 @@ The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)."
(textsec-single-script-p string1)
(textsec-single-script-p string2)))
+(defun textsec--ipvx-address-p (domain)
+ "Return non-nil if DOMAIN is an ipv4 or ipv6 address."
+ ;; This is a very relaxed pattern for IPv4 or IPv6 addresses. The
+ ;; assumption is that any malformed address accepted by this rule
+ ;; will be rejected by the actual address parser eventually.
+ (let ((case-fold-search t))
+ (rx-let ((ipv4 (** 1 4
+ (** 1 3 (in "0-9"))
+ (? ".")))
+ (ipv6 (: (** 1 7
+ (** 0 4 (in "0-9a-f"))
+ ":")
+ (** 0 4 (in "0-9a-f"))
+ (? ":" ipv4))))
+ (string-match-p (rx bos (or ipv4 ipv6 (: "[" ipv6 "]")) eos) domain))))
+
(defun textsec-domain-suspicious-p (domain)
"Say whether DOMAIN's name looks suspicious.
Return nil if it isn't suspicious. If it is, return a string explaining
@@ -241,6 +257,9 @@ that can look similar to other characters when displayed, or
use characters that are not allowed by Unicode's IDNA mapping,
or use certain other unusual mixtures of characters."
(catch 'found
+ ;; Plain domains aren't suspicious.
+ (when (textsec--ipvx-address-p domain)
+ (throw 'found nil))
(seq-do
(lambda (char)
(when (eq (elt idna-mapping-table char) t)
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 8970216398b..168d71ada3a 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -1813,17 +1813,19 @@ The following additional command keys are active while editing.
;; Search string might have meta information on text properties.
(minibuffer-allow-text-properties t))
(setq isearch-new-string
- (read-from-minibuffer
- (isearch-message-prefix nil isearch-nonincremental)
- (cons isearch-string (1+ (or (isearch-fail-pos)
- (length isearch-string))))
- minibuffer-local-isearch-map nil
- (if isearch-regexp
- (cons 'regexp-search-ring
- (1+ (or regexp-search-ring-yank-pointer -1)))
- (cons 'search-ring
- (1+ (or search-ring-yank-pointer -1))))
- nil t)
+ (minibuffer-with-setup-hook
+ (minibuffer-lazy-highlight-setup)
+ (read-from-minibuffer
+ (isearch-message-prefix nil isearch-nonincremental)
+ (cons isearch-string (1+ (or (isearch-fail-pos)
+ (length isearch-string))))
+ minibuffer-local-isearch-map nil
+ (if isearch-regexp
+ (cons 'regexp-search-ring
+ (1+ (or regexp-search-ring-yank-pointer -1)))
+ (cons 'search-ring
+ (1+ (or search-ring-yank-pointer -1))))
+ nil t))
isearch-new-message
(mapconcat 'isearch-text-char-description
isearch-new-string "")))))
@@ -2668,7 +2670,7 @@ or it might return the position of the end of the line."
(interactive "p")
(if (eobp)
(insert
- (with-current-buffer (cadr (buffer-list))
+ (with-minibuffer-selected-window
(buffer-substring-no-properties
(point) (progn (forward-char arg) (point)))))
(forward-char arg)))
@@ -3455,11 +3457,13 @@ the word mode."
(if (and (not isearch-success) (not isearch-case-fold-search))
"case-sensitive ")
(let ((prefix ""))
- (advice-function-mapc
- (lambda (_ props)
- (let ((np (cdr (assq 'isearch-message-prefix props))))
- (if np (setq prefix (concat np prefix)))))
- isearch-filter-predicate)
+ (dolist (advice-function (list isearch-filter-predicate
+ isearch-search-fun-function))
+ (advice-function-mapc
+ (lambda (_ props)
+ (let ((np (cdr (assq 'isearch-message-prefix props))))
+ (if np (setq prefix (concat np prefix)))))
+ advice-function))
prefix)
(isearch--describe-regexp-mode isearch-regexp-function)
(cond
@@ -3990,6 +3994,8 @@ since they have special meaning in a regexp."
(defvar isearch-lazy-count-current nil)
(defvar isearch-lazy-count-total nil)
(defvar isearch-lazy-count-hash (make-hash-table))
+(defvar lazy-count-update-hook nil
+ "Hook run after new lazy count results are computed.")
(defun lazy-highlight-cleanup (&optional force procrastinate)
"Stop lazy highlighting and remove extra highlighting from current buffer.
@@ -4048,7 +4054,7 @@ by other Emacs features."
isearch-lazy-highlight-window-end))))))
;; something important did indeed change
(lazy-highlight-cleanup t (not (equal isearch-string ""))) ;stop old timer
- (when (and isearch-lazy-count isearch-mode (null isearch-message-function))
+ (when isearch-lazy-count
(when (or (equal isearch-string "")
;; Check if this place was reached by a condition above
;; other than changed window boundaries (that shouldn't
@@ -4067,7 +4073,10 @@ by other Emacs features."
(setq isearch-lazy-count-current nil
isearch-lazy-count-total nil)
;; Delay updating the message if possible, to avoid flicker
- (when (string-equal isearch-string "") (isearch-message))))
+ (when (string-equal isearch-string "")
+ (when (and isearch-mode (null isearch-message-function))
+ (isearch-message))
+ (run-hooks 'lazy-count-update-hook))))
(setq isearch-lazy-highlight-window-start-changed nil)
(setq isearch-lazy-highlight-window-end-changed nil)
(setq isearch-lazy-highlight-error isearch-error)
@@ -4120,13 +4129,15 @@ by other Emacs features."
'isearch-lazy-highlight-start))))
;; Update the current match number only in isearch-mode and
;; unless isearch-mode is used specially with isearch-message-function
- (when (and isearch-lazy-count isearch-mode (null isearch-message-function))
+ (when isearch-lazy-count
;; Update isearch-lazy-count-current only when it was already set
;; at the end of isearch-lazy-highlight-buffer-update
(when isearch-lazy-count-current
(setq isearch-lazy-count-current
(gethash (point) isearch-lazy-count-hash 0))
- (isearch-message))))
+ (when (and isearch-mode (null isearch-message-function))
+ (isearch-message))
+ (run-hooks 'lazy-count-update-hook))))
(defun isearch-lazy-highlight-search (string bound)
"Search ahead for the next or previous match, for lazy highlighting.
@@ -4327,16 +4338,106 @@ Attempt to do the search exactly the way the pending Isearch would."
(setq looping nil
nomore t))))
(if nomore
- (when (and isearch-lazy-count isearch-mode (null isearch-message-function))
+ (when isearch-lazy-count
(unless isearch-lazy-count-total
(setq isearch-lazy-count-total 0))
(setq isearch-lazy-count-current
(gethash opoint isearch-lazy-count-hash 0))
- (isearch-message))
+ (when (and isearch-mode (null isearch-message-function))
+ (isearch-message)))
(setq isearch-lazy-highlight-timer
(run-at-time lazy-highlight-interval nil
- 'isearch-lazy-highlight-buffer-update)))))))))
+ 'isearch-lazy-highlight-buffer-update)))))
+ (when (and nomore isearch-lazy-count)
+ (run-hooks 'lazy-count-update-hook))))))
+
+;; Reading from minibuffer with lazy highlight and match count
+
+(defcustom minibuffer-lazy-count-format "%s "
+ "Format of the total number of matches for the prompt prefix."
+ :type '(choice (const :tag "Don't display a count" nil)
+ (string :tag "Display match count" "%s "))
+ :group 'lazy-count
+ :version "29.1")
+
+(cl-defun minibuffer-lazy-highlight-setup
+ (&key (highlight isearch-lazy-highlight)
+ (cleanup lazy-highlight-cleanup)
+ (transform #'identity)
+ (filter nil)
+ (regexp isearch-regexp)
+ (regexp-function isearch-regexp-function)
+ (case-fold isearch-case-fold-search)
+ (lax-whitespace (if regexp
+ isearch-regexp-lax-whitespace
+ isearch-lax-whitespace)))
+ "Set up minibuffer for lazy highlight of matches in the original window.
+
+This function return a closure intended to be added to
+`minibuffer-setup-hook'. It accepts the following keyword
+arguments, all of which have a default based on the current
+isearch settings.
+
+HIGHLIGHT: Whether to perform lazy highlight.
+CLEANUP: Whether to clean up the lazy highlight when the minibuffer
+exits.
+TRANSFORM: A function taking one argument, the minibuffer contents,
+and returning the `isearch-string' to use for lazy highlighting.
+FILTER: A function to add to `isearch-filter-predicate'.
+REGEXP: The value of `isearch-regexp' to use for lazy highlighting.
+REGEXP-FUNCTION: The value of `isearch-regexp-function' to use for
+lazy highlighting.
+CASE-FOLD: The value of `isearch-case-fold' to use for lazy
+highlighting.
+LAX-WHITESPACE: The value of `isearch-lax-whitespace' and
+`isearch-regexp-lax-whitespace' to use for lazy highlighting."
+ (if (not highlight)
+ #'ignore
+ (let ((unwind (make-symbol "minibuffer-lazy-highlight--unwind"))
+ (after-change (make-symbol "minibuffer-lazy-highlight--after-change"))
+ (display-count (make-symbol "minibuffer-lazy-highlight--display-count"))
+ overlay)
+ (fset unwind
+ (lambda ()
+ (remove-function isearch-filter-predicate filter)
+ (remove-hook 'lazy-count-update-hook display-count)
+ (when overlay (delete-overlay overlay))
+ (remove-hook 'after-change-functions after-change)
+ (remove-hook 'minibuffer-exit-hook unwind)
+ (let ((lazy-highlight-cleanup cleanup))
+ (lazy-highlight-cleanup))))
+ (fset after-change
+ (lambda (_beg _end _len)
+ (let ((inhibit-redisplay t) ;; Avoid cursor flickering
+ (string (minibuffer-contents)))
+ (with-minibuffer-selected-window
+ (let* ((isearch-forward t)
+ (isearch-regexp regexp)
+ (isearch-regexp-function regexp-function)
+ (isearch-case-fold-search case-fold)
+ (isearch-lax-whitespace lax-whitespace)
+ (isearch-regexp-lax-whitespace lax-whitespace)
+ (isearch-string (funcall transform string)))
+ (isearch-lazy-highlight-new-loop))))))
+ (fset display-count
+ (lambda ()
+ (overlay-put overlay 'before-string
+ (and isearch-lazy-count-total
+ (not isearch-error)
+ (format minibuffer-lazy-count-format
+ isearch-lazy-count-total)))))
+ (lambda ()
+ (add-hook 'minibuffer-exit-hook unwind)
+ (add-hook 'after-change-functions after-change)
+ (when minibuffer-lazy-count-format
+ (setq overlay (make-overlay (point-min) (point-min) (current-buffer) t))
+ (add-hook 'lazy-count-update-hook display-count))
+ (when filter
+ (add-function :after-while isearch-filter-predicate filter))
+ (funcall after-change nil nil nil)))))
+
+
(defun isearch-resume (string regexp word forward message case-fold)
"Resume an incremental search.
STRING is the string or regexp searched for.
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 9bbaaa666da..8a9d89929eb 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -362,9 +362,13 @@ information."
;;; Keyboard macro ring
+(oclosure-define kmacro
+ "Keyboard macro."
+ keys (counter :mutable t) format)
+
(defvar kmacro-ring nil
"The keyboard macro ring.
-Each element is a list (MACRO COUNTER FORMAT). Actually, the head of
+Each element is a `kmacro'. Actually, the head of
the macro ring (when defining or executing) is not stored in the ring;
instead it is available in the variables `last-kbd-macro', `kmacro-counter',
and `kmacro-counter-format'.")
@@ -378,20 +382,23 @@ and `kmacro-counter-format'.")
(defun kmacro-ring-head ()
"Return pseudo head element in macro ring."
(and last-kbd-macro
- (list last-kbd-macro kmacro-counter kmacro-counter-format-start)))
+ (kmacro last-kbd-macro kmacro-counter kmacro-counter-format-start)))
(defun kmacro-push-ring (&optional elt)
"Push ELT or current macro onto `kmacro-ring'."
(when (setq elt (or elt (kmacro-ring-head)))
+ (when (consp elt)
+ (message "Converting obsolete list form of kmacro: %S" elt)
+ (setq elt (apply #'kmacro elt)))
(let ((history-delete-duplicates nil))
(add-to-history 'kmacro-ring elt kmacro-ring-max))))
(defun kmacro-split-ring-element (elt)
- (setq last-kbd-macro (car elt)
- kmacro-counter (nth 1 elt)
- kmacro-counter-format-start (nth 2 elt)))
+ (setq last-kbd-macro (kmacro--keys elt)
+ kmacro-counter (kmacro--counter elt)
+ kmacro-counter-format-start (kmacro--format elt)))
(defun kmacro-pop-ring1 (&optional raw)
@@ -481,21 +488,16 @@ Optional arg EMPTY is message to print if no macros are defined."
;;;###autoload
-(defun kmacro-exec-ring-item (item arg)
+(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1"
"Execute item ITEM from the macro ring.
-ARG is the number of times to execute the item."
- ;; Use counter and format specific to the macro on the ring!
- (let ((kmacro-counter (nth 1 item))
- (kmacro-counter-format-start (nth 2 item)))
- (execute-kbd-macro (car item) arg #'kmacro-loop-setup-function)
- (setcar (cdr item) kmacro-counter)))
+ARG is the number of times to execute the item.")
(defun kmacro-call-ring-2nd (arg)
"Execute second keyboard macro in macro ring."
(interactive "P")
(unless (kmacro-ring-empty-p)
- (kmacro-exec-ring-item (car kmacro-ring) arg)))
+ (funcall (car kmacro-ring) arg)))
(defun kmacro-call-ring-2nd-repeat (arg)
@@ -515,7 +517,7 @@ without repeating the prefix."
"Display the second macro in the keyboard macro ring."
(interactive)
(unless (kmacro-ring-empty-p)
- (kmacro-display (car (car kmacro-ring)) nil "2nd macro")))
+ (kmacro-display (kmacro--keys (car kmacro-ring)) nil "2nd macro")))
(defun kmacro-cycle-ring-next (&optional _arg)
@@ -611,8 +613,7 @@ Use \\[kmacro-bind-to-key] to bind it to a key sequence."
(let ((append (and arg (listp arg))))
(unless append
(if last-kbd-macro
- (kmacro-push-ring
- (list last-kbd-macro kmacro-counter kmacro-counter-format-start)))
+ (kmacro-push-ring))
(setq kmacro-counter (or (if arg (prefix-numeric-value arg))
kmacro-initial-counter-value
0)
@@ -748,9 +749,9 @@ With \\[universal-argument], call second macro in macro ring."
(if kmacro-call-repeat-key
(kmacro-call-macro arg no-repeat t)
(kmacro-end-macro arg)))
- ((and (eq this-command 'kmacro-view-macro) ;; We are in repeat mode!
+ ((and (eq this-command #'kmacro-view-macro) ;; We are in repeat mode!
kmacro-view-last-item)
- (kmacro-exec-ring-item (car kmacro-view-last-item) arg))
+ (funcall (car kmacro-view-last-item) arg))
((and arg (listp arg))
(kmacro-call-ring-2nd 1))
(t
@@ -812,41 +813,66 @@ If kbd macro currently being defined end it before activating it."
;; executing the macro later on (but that's controversial...)
;;;###autoload
+(defun kmacro (keys &optional counter format)
+ "Create a `kmacro' for macro bound to symbol or key.
+KEYS should be a vector or a string that obeys `key-valid-p'."
+ (oclosure-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys))
+ (counter (or counter 0))
+ (format (or format "%d")))
+ (&optional arg)
+ (interactive "p")
+ ;; Use counter and format specific to the macro on the ring!
+ (let ((kmacro-counter counter)
+ (kmacro-counter-format-start format))
+ (execute-kbd-macro keys arg #'kmacro-loop-setup-function)
+ (setq counter kmacro-counter))))
+
+;;;###autoload
(defun kmacro-lambda-form (mac &optional counter format)
- "Create lambda form for macro bound to symbol or key."
;; Apparently, there are two different ways this is called:
;; either `counter' and `format' are both provided and `mac' is a vector,
;; or only `mac' is provided, as a list (MAC COUNTER FORMAT).
;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit',
;; while the second is used from within this file.
- (let ((mac (if counter (list mac counter format) mac)))
- ;; FIXME: This should be a "funcallable struct"!
- (lambda (&optional arg)
- "Keyboard macro."
- ;; We put an "unused prompt" as a special marker so
- ;; `kmacro-extract-lambda' can see it's "one of us".
- (interactive "pkmacro")
- (if (eq arg 'kmacro--extract-lambda)
- (cons 'kmacro--extract-lambda mac)
- (kmacro-exec-ring-item mac arg)))))
+ (declare (obsolete kmacro "29.1"))
+ (if (kmacro-p mac) mac
+ (when (and (null counter) (consp mac))
+ (setq format (nth 2 mac))
+ (setq counter (nth 1 mac))
+ (setq mac (nth 0 mac)))
+ (when (stringp mac)
+ ;; `kmacro' interprets a string according to `key-parse'.
+ (require 'macros)
+ (declare-function macro--string-to-vector "macros")
+ (setq mac (macro--string-to-vector mac)))
+ (kmacro mac counter format)))
(defun kmacro-extract-lambda (mac)
"Extract kmacro from a kmacro lambda form."
- (let ((mac (cond
- ((eq (car-safe mac) 'lambda)
- (let ((e (assoc 'kmacro-exec-ring-item mac)))
- (car-safe (cdr-safe (car-safe (cdr-safe e))))))
- ((and (functionp mac)
- (equal (interactive-form mac) '(interactive "pkmacro")))
- (let ((r (funcall mac 'kmacro--extract-lambda)))
- (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r)))))))
- (and (consp mac)
- (= (length mac) 3)
- (arrayp (car mac))
- mac)))
-
-(defalias 'kmacro-p #'kmacro-extract-lambda
- "Return non-nil if MAC is a kmacro keyboard macro.")
+ (declare (obsolete nil "29.1"))
+ (when (kmacro-p mac)
+ (list (kmacro--keys mac)
+ (kmacro--counter mac)
+ (kmacro--format mac))))
+
+(defun kmacro-p (x)
+ "Return non-nil if MAC is a kmacro keyboard macro."
+ (cl-typep x 'kmacro))
+
+(cl-defmethod cl-print-object ((object kmacro) stream)
+ (princ "#f(kmacro " stream)
+ (require 'macros)
+ (declare-function macros--insert-vector-macro "macros" (definition))
+ (let ((vecdef (kmacro--keys object))
+ (counter (kmacro--counter object))
+ (format (kmacro--format object)))
+ (prin1 (key-description vecdef) stream)
+ (unless (and (equal counter 0) (equal format "%d"))
+ (princ " " stream)
+ (prin1 counter stream)
+ (princ " " stream)
+ (prin1 format stream))
+ (princ ")" stream)))
(defun kmacro-bind-to-key (_arg)
"When not defining or executing a macro, offer to bind last macro to a key.
@@ -884,16 +910,15 @@ The ARG parameter is unused."
(yes-or-no-p (format "%s runs command %S. Bind anyway? "
(format-kbd-macro key-seq)
cmd))))
- (define-key global-map key-seq
- (kmacro-lambda-form (kmacro-ring-head)))
+ (define-key global-map key-seq (kmacro-ring-head))
(message "Keyboard macro bound to %s" (format-kbd-macro key-seq))))))
(defun kmacro-keyboard-macro-p (symbol)
"Return non-nil if SYMBOL is the name of some sort of keyboard macro."
(let ((f (symbol-function symbol)))
(when f
- (or (stringp f)
- (vectorp f)
+ (or (stringp f) ;FIXME: Really deprecated.
+ (vectorp f) ;FIXME: Deprecated.
(kmacro-p f)))))
(defun kmacro-name-last-macro (symbol)
@@ -910,9 +935,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
symbol))
(if (string-equal symbol "")
(error "No command name given"))
- ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't
- ;; make a difference?
- (fset symbol (kmacro-lambda-form (kmacro-ring-head)))
+ (fset symbol (kmacro-ring-head))
;; This used to be used to detect when a symbol corresponds to a kmacro.
;; Nowadays it's unused because we used `kmacro-p' instead to see if the
;; symbol's function definition matches that of a kmacro, which is more
@@ -953,7 +976,7 @@ The ARG parameter is unused."
(interactive)
(cond
((or (kmacro-ring-empty-p)
- (not (eq last-command 'kmacro-view-macro)))
+ (not (eq last-command #'kmacro-view-macro)))
(setq kmacro-view-last-item nil))
((null kmacro-view-last-item)
(setq kmacro-view-last-item kmacro-ring
@@ -963,10 +986,10 @@ The ARG parameter is unused."
kmacro-view-item-no (1+ kmacro-view-item-no)))
(t
(setq kmacro-view-last-item nil)))
- (setq this-command 'kmacro-view-macro
+ (setq this-command #'kmacro-view-macro
last-command this-command) ;; in case we repeat
(kmacro-display (if kmacro-view-last-item
- (car (car kmacro-view-last-item))
+ (kmacro--keys (car kmacro-view-last-item))
last-kbd-macro)
nil
(if kmacro-view-last-item
@@ -1068,21 +1091,27 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(concat
(format "Macro: %s%s%s%s%s\n"
(format-kbd-macro kmacro-step-edit-new-macro 1)
- (if (and kmacro-step-edit-new-macro (> (length kmacro-step-edit-new-macro) 0)) " " "")
+ (if (and kmacro-step-edit-new-macro
+ (> (length kmacro-step-edit-new-macro) 0))
+ " " "")
(propertize (if keys (format-kbd-macro keys)
- (if kmacro-step-edit-appending "<APPEND>" "<INSERT>")) 'face 'region)
+ (if kmacro-step-edit-appending
+ "<APPEND>" "<INSERT>"))
+ 'face 'region)
(if future " " "")
(if future (format-kbd-macro future) ""))
(cond
((minibufferp)
(format "%s\n%s\n"
(propertize "\
- minibuffer " 'face 'header-line)
+ minibuffer "
+ 'face 'header-line)
(buffer-substring (point-min) (point-max))))
(curmsg
(format "%s\n%s\n"
(propertize "\
- echo area " 'face 'header-line)
+ echo area "
+ 'face 'header-line)
curmsg))
(t ""))
(if keys
@@ -1113,7 +1142,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
;; Handle commands which reads additional input using read-char.
(cond
- ((and (eq this-command 'quoted-insert)
+ ((and (eq this-command #'quoted-insert)
(not (eq kmacro-step-edit-action t)))
;; Find the actual end of this key sequence.
;; Must be able to backtrack in case we actually execute it.
@@ -1133,7 +1162,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(cond
((eq kmacro-step-edit-action t) ;; Reentry for actual command @ end of prefix arg.
(cond
- ((eq this-command 'quoted-insert)
+ ((eq this-command #'quoted-insert)
(clear-this-command-keys) ;; recent-keys actually
(let (unread-command-events)
(quoted-insert (prefix-numeric-value current-prefix-arg))
@@ -1177,7 +1206,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
((eq act 'skip)
nil)
((eq act 'skip-keep)
- (setq this-command 'ignore)
+ (setq this-command #'ignore)
t)
((eq act 'skip-rest)
(setq kmacro-step-edit-active 'ignore)
@@ -1227,7 +1256,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(if restore-index
(setq executing-kbd-macro-index restore-index)))
(t
- (setq this-command 'ignore)))
+ (setq this-command #'ignore)))
(setq kmacro-step-edit-key-index next-index)))
(defun kmacro-step-edit-insert ()
@@ -1271,7 +1300,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(setq next-index kmacro-step-edit-key-index)
t)
(t nil))
- (setq this-command 'ignore)
+ (setq this-command #'ignore)
(setq this-command cmd)
(if (memq this-command '(self-insert-command digit-argument))
(setq last-command-event (aref keys (1- (length keys)))))
@@ -1284,7 +1313,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(when kmacro-step-edit-active
(cond
((eq kmacro-step-edit-active 'ignore)
- (setq this-command 'ignore))
+ (setq this-command #'ignore))
((eq kmacro-step-edit-active 'append-end)
(if (= executing-kbd-macro-index (length executing-kbd-macro))
(setq executing-kbd-macro (vconcat executing-kbd-macro [nil])
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 9f5169605b5..5dd4291461c 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -1581,78 +1581,6 @@ key2: value2
;;;***
-;;;### (autoloads nil "autoarg" "autoarg.el" (0 0 0 0))
-;;; Generated autoloads from autoarg.el
-
-(defvar autoarg-mode nil "\
-Non-nil if Autoarg mode is enabled.
-See the `autoarg-mode' command
-for a description of this minor mode.")
-
-(custom-autoload 'autoarg-mode "autoarg" nil)
-
-(autoload 'autoarg-mode "autoarg" "\
-Toggle Autoarg mode, a global minor mode.
-
-\\<autoarg-mode-map>
-In Autoarg mode, digits are bound to `digit-argument', i.e. they
-supply prefix arguments as C-DIGIT and M-DIGIT normally do.
-Furthermore, C-DIGIT inserts DIGIT.
-\\[autoarg-terminate] terminates the prefix sequence and inserts
-the digits of the autoarg sequence into the buffer.
-Without a numeric prefix arg, the normal binding of \\[autoarg-terminate]
-is invoked, i.e. what it would be with Autoarg mode off.
-
-For example:
-`6 9 \\[autoarg-terminate]' inserts `69' into the buffer, as does `C-6 C-9'.
-`6 9 a' inserts 69 `a's into the buffer.
-`6 9 \\[autoarg-terminate] \\[autoarg-terminate]' inserts `69' into the buffer and
-then invokes the normal binding of \\[autoarg-terminate].
-`\\[universal-argument] \\[autoarg-terminate]' invokes the normal binding of \\[autoarg-terminate] four times.
-
-\\{autoarg-mode-map}
-
-\(fn &optional ARG)" t nil)
-
-(defvar autoarg-kp-mode nil "\
-Non-nil if Autoarg-Kp mode is enabled.
-See the `autoarg-kp-mode' command
-for a description of this minor mode.
-Setting this variable directly does not take effect;
-either customize it (see the info node `Easy Customization')
-or call the function `autoarg-kp-mode'.")
-
-(custom-autoload 'autoarg-kp-mode "autoarg" nil)
-
-(autoload 'autoarg-kp-mode "autoarg" "\
-Toggle Autoarg-KP mode, a global minor mode.
-
-This is a minor mode. If called interactively, toggle the `Autoarg-Kp
-mode' mode. If the prefix argument is positive, enable the mode, and
-if it is zero or negative, disable the mode.
-
-If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
-mode if ARG is nil, omitted, or is a positive number. Disable the
-mode if ARG is a negative number.
-
-To check whether the minor mode is enabled in the current buffer,
-evaluate `(default-value \\='autoarg-kp-mode)'.
-
-The mode's hook is called both when the mode is enabled and when it is
-disabled.
-
-\\<autoarg-kp-mode-map>
-This is similar to `autoarg-mode' but rebinds the keypad keys
-`kp-1' etc. to supply digit arguments.
-
-\\{autoarg-kp-mode-map}
-
-\(fn &optional ARG)" t nil)
-
-(register-definition-prefixes "autoarg" '("autoarg-"))
-
-;;;***
-
;;;### (autoloads nil "autoconf" "progmodes/autoconf.el" (0 0 0 0))
;;; Generated autoloads from progmodes/autoconf.el
@@ -6517,6 +6445,19 @@ If given a prefix (or a COMMENT argument), also prompt for a comment.
\(fn VARIABLE VALUE &optional COMMENT)" t nil)
+(autoload 'setopt "cus-edit" "\
+Set VARIABLE/VALUE pairs, and return the final VALUE.
+This is like `setq', but is meant for user options instead of
+plain variables. This means that `setopt' will execute any
+`custom-set' form associated with VARIABLE.
+
+\(fn [VARIABLE VALUE]...)" nil t)
+
+(autoload 'setopt--set "cus-edit" "\
+
+
+\(fn VARIABLE VALUE)" nil nil)
+
(autoload 'customize-save-variable "cus-edit" "\
Set the default for VARIABLE to VALUE, and save it for future sessions.
Return VALUE.
@@ -6690,7 +6631,7 @@ Customize all loaded groups matching REGEXP.
(autoload 'custom-prompt-customize-unsaved-options "cus-edit" "\
Prompt user to customize any unsaved customization options.
-Return non-nil if user chooses to customize, for use in
+Return nil if user chooses to customize, for use in
`kill-emacs-query-functions'." nil nil)
(autoload 'custom-buffer-create "cus-edit" "\
@@ -8045,7 +7986,7 @@ some of the `ls' switches are not supported; see the doc string of
(custom-autoload 'dired-listing-switches "dired" t)
-(defvar dired-directory nil "\
+(defvar-local dired-directory nil "\
The directory name or wildcard spec that this Dired directory lists.
Local to each Dired buffer. May be a list, in which case the car is the
directory name and the cdr is the list of files to mention.
@@ -10397,6 +10338,11 @@ For example, to instrument all ELP functions, do the following:
\\[elp-instrument-package] RET elp- RET
+Note that only functions that are currently loaded will be
+instrumented. If you run this function, and then later load
+further functions that start with PREFIX, they will not be
+instrumented automatically.
+
\(fn PREFIX)" t nil)
(autoload 'elp-results "elp" "\
@@ -11854,6 +11800,15 @@ If ERROR is non-nil, report an error if there is none.
\(fn NAME &optional ERROR)" t nil)
+(autoload 'eudc-expand-try-all "eudc" "\
+Wrap `eudc-expand-inline' with a prefix argument.
+If TRY-ALL-SERVERS -- the prefix argument when called
+interactively -- is non-nil, collect results from all servers.
+If TRY-ALL-SERVERS is nil, do not try subsequent servers after
+one server returns any match.
+
+\(fn &optional TRY-ALL-SERVERS)" t nil)
+
(autoload 'eudc-expand-inline "eudc" "\
Query the directory server, and expand the query string before point.
The query string consists of the buffer substring from the point back to
@@ -11862,12 +11817,14 @@ The variable `eudc-inline-query-format' controls how to associate the
individual inline query words with directory attribute names.
After querying the server for the given string, the expansion specified by
`eudc-inline-expansion-format' is inserted in the buffer at point.
-If REPLACE is non-nil, then this expansion replaces the name in the buffer.
-`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE.
+If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion
+text to the kill ring. `eudc-expansion-save-query-as-kill' being
+non-nil inverts the meaning of SAVE-QUERY-AS-KILL.
Multiple servers can be tried with the same query until one finds a match,
-see `eudc-inline-expansion-servers'.
+see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is
+non-nil, collect results from all servers.
-\(fn &optional REPLACE)" t nil)
+\(fn &optional SAVE-QUERY-AS-KILL TRY-ALL-SERVERS)" t nil)
(autoload 'eudc-query-with-words "eudc" "\
Query the directory server, and return the matching responses.
@@ -11877,9 +11834,10 @@ After querying the server for the given string, the expansion
specified by `eudc-inline-expansion-format' is applied to the
matches before returning them.inserted in the buffer at point.
Multiple servers can be tried with the same query until one finds a match,
-see `eudc-inline-expansion-servers'.
+see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil,
+keep collecting results from subsequent servers after the first match.
-\(fn QUERY-WORDS)" nil nil)
+\(fn QUERY-WORDS &optional TRY-ALL-SERVERS)" nil nil)
(autoload 'eudc-query-form "eudc" "\
Display a form to query the directory server.
@@ -13058,6 +13016,9 @@ Interactively, prompt for LIBRARY using the one at or near point.
This function searches `find-library-source-path' if non-nil, and
`load-path' otherwise.
+See the `find-library-include-other-files' user option for
+customizing the candidate completions.
+
\(fn LIBRARY)" t nil)
(autoload 'read-library-name "find-func" "\
@@ -13218,7 +13179,7 @@ Find directly the variable at point in the other window." t nil)
(autoload 'find-function-setup-keys "find-func" "\
Define some key bindings for the `find-function' family of functions." nil nil)
-(register-definition-prefixes "find-func" '("find-"))
+(register-definition-prefixes "find-func" '("find-" "read-library-name--find-files"))
;;;***
@@ -13309,7 +13270,7 @@ lines.
;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0))
;;; Generated autoloads from progmodes/flymake.el
-(push (purecopy '(flymake 1 2 1)) package--builtin-versions)
+(push (purecopy '(flymake 1 2 2)) package--builtin-versions)
(autoload 'flymake-log "flymake" "\
Log, at level LEVEL, the message MSG formatted with ARGS.
@@ -13471,6 +13432,9 @@ Flyspell mode is a buffer-local minor mode. When enabled, it
spawns a single Ispell process and checks each word. The default
flyspell behavior is to highlight incorrect words.
+This mode is geared toward text modes. In buffers that contain
+code, `flyspell-prog-mode' is usually a better choice.
+
Bindings:
\\[ispell-word]: correct words (using Ispell).
\\[flyspell-auto-correct-word]: automatically correct word.
@@ -16237,10 +16201,15 @@ If TYPE is not a symbol, search for a function definition.
The return value is the absolute name of a readable file where OBJECT is
defined. If several such files exist, preference is given to a file
found via `load-path'. The return value can also be `C-source', which
-means that OBJECT is a function or variable defined in C. If no
-suitable file is found, return nil.
+means that OBJECT is a function or variable defined in C, but
+it's currently unknown where. If no suitable file is found,
+return nil.
-\(fn OBJECT TYPE)" nil nil)
+If ALSO-C-SOURCE is non-nil, instead of returning `C-source',
+this function will attempt to locate the definition of OBJECT in
+the C sources, too.
+
+\(fn OBJECT TYPE &optional ALSO-C-SOURCE)" nil nil)
(autoload 'describe-function-1 "help-fns" "\
@@ -17148,7 +17117,7 @@ argument VERBOSE non-nil makes the function verbose.
;;; Generated autoloads from hl-line.el
(autoload 'hl-line-mode "hl-line" "\
-Toggle highlighting of the current line (Hl-Line mode).
+Toggle highlighting of the current line.
This is a minor mode. If called interactively, toggle the `Hl-Line
mode' mode. If the prefix argument is positive, enable the mode, and
@@ -17164,18 +17133,10 @@ evaluate `hl-line-mode'.
The mode's hook is called both when the mode is enabled and when it is
disabled.
-Hl-Line mode is a buffer-local minor mode. If
-`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the
-line about the buffer's point in all windows. Caveat: the
-buffer's point might be different from the point of a
-non-selected window. Hl-Line mode uses the function
-`hl-line-highlight' on `post-command-hook' in this case.
-
-When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the
-line about point in the selected window only.
-
\(fn &optional ARG)" t nil)
+(put 'global-hl-line-mode 'globalized-minor-mode t)
+
(defvar global-hl-line-mode nil "\
Non-nil if Global Hl-Line mode is enabled.
See the `global-hl-line-mode' command
@@ -17187,32 +17148,22 @@ or call the function `global-hl-line-mode'.")
(custom-autoload 'global-hl-line-mode "hl-line" nil)
(autoload 'global-hl-line-mode "hl-line" "\
-Toggle line highlighting in all buffers (Global Hl-Line mode).
-
-This is a minor mode. If called interactively, toggle the `Global
-Hl-Line mode' mode. If the prefix argument is positive, enable the
-mode, and if it is zero or negative, disable the mode.
-
-If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
-mode if ARG is nil, omitted, or is a positive number. Disable the
-mode if ARG is a negative number.
-
-To check whether the minor mode is enabled in the current buffer,
-evaluate `(default-value \\='global-hl-line-mode)'.
+Toggle Hl-Line mode in all buffers.
+With prefix ARG, enable Global Hl-Line mode if ARG is positive;
+otherwise, disable it.
-The mode's hook is called both when the mode is enabled and when it is
-disabled.
+If called from Lisp, toggle the mode if ARG is `toggle'.
+Enable the mode if ARG is nil, omitted, or is a positive number.
+Disable the mode if ARG is a negative number.
-If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode
-highlights the line about the current buffer's point in all live
-windows.
+Hl-Line mode is enabled in all buffers where `hl-line-turn-on' would
+do it.
-Global-Hl-Line mode uses the function `global-hl-line-highlight'
-on `post-command-hook'.
+See `hl-line-mode' for more information on Hl-Line mode.
\(fn &optional ARG)" t nil)
-(register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-"))
+(register-definition-prefixes "hl-line" '("hl-line-"))
;;;***
@@ -18251,6 +18202,14 @@ See `inferior-emacs-lisp-mode' for details.
;;;***
+;;;### (autoloads nil "ietf-drums-date" "mail/ietf-drums-date.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from mail/ietf-drums-date.el
+
+(register-definition-prefixes "ietf-drums-date" '("date-parse-error" "ietf-drums-"))
+
+;;;***
+
;;;### (autoloads nil "iimage" "iimage.el" (0 0 0 0))
;;; Generated autoloads from iimage.el
@@ -18984,7 +18943,7 @@ quoted using shell quote syntax.
;;;### (autoloads nil "info" "info.el" (0 0 0 0))
;;; Generated autoloads from info.el
-(defcustom Info-default-directory-list (let* ((config-dir (file-name-as-directory (or (and (featurep 'ns) (let ((dir (expand-file-name "../info" data-directory))) (if (file-directory-p dir) dir))) configure-info-directory))) (prefixes (prune-directory-list '("/usr/local/" "/usr/" "/opt/"))) (suffixes '("share/" "")) (standard-info-dirs (apply #'nconc (mapcar (lambda (pfx) (let ((dirs (mapcar (lambda (sfx) (concat pfx sfx "info/")) suffixes))) (prune-directory-list dirs))) prefixes))) (dirs (if (member config-dir standard-info-dirs) (nconc standard-info-dirs (list config-dir)) (cons config-dir standard-info-dirs)))) (if (not (eq system-type 'windows-nt)) dirs (let* ((instdir (file-name-directory invocation-directory)) (dir1 (expand-file-name "../info/" instdir)) (dir2 (expand-file-name "../../../info/" instdir))) (cond ((file-exists-p dir1) (append dirs (list dir1))) ((file-exists-p dir2) (append dirs (list dir2))) (t dirs))))) "\
+(defvar Info-default-directory-list nil "\
Default list of directories to search for Info documentation files.
They are searched in the order they are given in the list.
Therefore, the directory of Info files that come with Emacs
@@ -18995,13 +18954,10 @@ first in this list.
Once Info is started, the list of directories to search
comes from the variable `Info-directory-list'.
-This variable `Info-default-directory-list' is used as the default
-for initializing `Info-directory-list' when Info is started, unless
-the environment variable INFOPATH is set.
-Although this is a customizable variable, that is mainly for technical
-reasons. Normally, you should either set INFOPATH or customize
-`Info-additional-directory-list', rather than changing this variable." :initialize #'custom-initialize-delay :type '(repeat directory))
+This variable is used as the default for initializing
+`Info-directory-list' when Info is started, unless the
+environment variable INFOPATH is set.")
(custom-autoload 'Info-default-directory-list "info" t)
@@ -25153,6 +25109,15 @@ downloads in the background.
\(fn &optional ASYNC)" t nil)
+(autoload 'package-installed-p "package" "\
+Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed.
+If PACKAGE is a symbol, it is the package name and MIN-VERSION
+should be a version list.
+
+If PACKAGE is a `package-desc' object, MIN-VERSION is ignored.
+
+\(fn PACKAGE &optional MIN-VERSION)" nil nil)
+
(autoload 'package-install "package" "\
Install the package PKG.
PKG can be a `package-desc' or a symbol naming one of the
@@ -27425,8 +27390,8 @@ If it is nil, the current key is shown.
DOCSTRING is the documentation string of this package. The command
`describe-input-method' shows this string while replacing the form
-\\=\\<VAR> in the string by the value of VAR. That value should be a
-string. For instance, the form \\=\\<quail-translation-docstring> is
+\\=\\=\\=\\<VAR> in the string by the value of VAR. That value should be a
+string. For instance, the form \\=\\=\\=\\<quail-translation-docstring> is
replaced by a description about how to select a translation from a
list of candidates.
@@ -29314,7 +29279,7 @@ to use for finding the schema.
;;;### (autoloads nil "rng-xsd" "nxml/rng-xsd.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-xsd.el
-(put 'http://www\.w3\.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile)
+(put 'http://www.w3.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile)
(autoload 'rng-xsd-compile "rng-xsd" "\
Provide W3C XML Schema as a RELAX NG datatypes library.
@@ -30009,7 +29974,7 @@ will scroll the buffer by the respective amount of lines instead
and point will be kept vertically fixed relative to window
boundaries during scrolling.
-Note that the default key binding to Scroll_Lock will not work on
+Note that the default key binding to `scroll' will not work on
MS-Windows systems if `w32-scroll-lock-modifier' is non-nil.
\(fn &optional ARG)" t nil)
@@ -31675,7 +31640,7 @@ configure the behaviour.
;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0))
;;; Generated autoloads from net/soap-client.el
-(push (purecopy '(soap-client 3 2 0)) package--builtin-versions)
+(push (purecopy '(soap-client 3 2 1)) package--builtin-versions)
(register-definition-prefixes "soap-client" '("soap-"))
@@ -33027,8 +32992,8 @@ The mode's hook is called both when the mode is enabled and when it is
disabled.
Superword mode is a buffer-local minor mode. Enabling it changes
-the definition of words such that symbols characters are treated
-as parts of words: e.g., in `superword-mode',
+the definition of words such that characters which have symbol
+syntax are treated as parts of words: e.g., in `superword-mode',
\"this_is_a_symbol\" counts as one word.
\\{superword-mode-map}
@@ -36310,7 +36275,7 @@ Handle file: and ftp: URLs.
\(fn URL CALLBACK CBARGS)" nil nil)
-(register-definition-prefixes "url-file" '("url-file-"))
+(register-definition-prefixes "url-file" '("url-"))
;;;***
@@ -38767,17 +38732,10 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;***
-;;;### (autoloads nil "vt-control" "vt-control.el" (0 0 0 0))
-;;; Generated autoloads from vt-control.el
-
-(register-definition-prefixes "vt-control" '("vt-"))
-
-;;;***
-
-;;;### (autoloads nil "vt100-led" "vt100-led.el" (0 0 0 0))
-;;; Generated autoloads from vt100-led.el
+;;;### (autoloads nil "vtable" "emacs-lisp/vtable.el" (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/vtable.el
-(register-definition-prefixes "vt100-led" '("led-"))
+(register-definition-prefixes "vtable" '("vtable"))
;;;***
@@ -39863,7 +39821,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT.
;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0))
;;; Generated autoloads from progmodes/xref.el
-(push (purecopy '(xref 1 3 2)) package--builtin-versions)
+(push (purecopy '(xref 1 4 1)) package--builtin-versions)
(autoload 'xref-find-backend "xref" nil nil nil)
@@ -39882,6 +39840,13 @@ Whether the xref back-history is empty." nil nil)
(autoload 'xref-forward-history-empty-p "xref" "\
Whether the xref forward-history is empty." nil nil)
+(autoload 'xref-show-xrefs "xref" "\
+Display some Xref values produced by FETCHER using DISPLAY-ACTION.
+The meanings of both arguments are the same as documented in
+`xref-show-xrefs-function'.
+
+\(fn FETCHER DISPLAY-ACTION)" nil nil)
+
(autoload 'xref-find-definitions "xref" "\
Find the definition of the identifier at point.
With prefix argument or when there's no identifier at point,
@@ -40115,24 +40080,23 @@ Zone out, completely." t nil)
;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el"
;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el"
-;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/base.el" "cedet/ede/config.el"
-;;;;;; "cedet/ede/cpp-root.el" "cedet/ede/custom.el" "cedet/ede/dired.el"
-;;;;;; "cedet/ede/emacs.el" "cedet/ede/files.el" "cedet/ede/generic.el"
-;;;;;; "cedet/ede/linux.el" "cedet/ede/locate.el" "cedet/ede/make.el"
-;;;;;; "cedet/ede/shell.el" "cedet/ede/speedbar.el" "cedet/ede/system.el"
-;;;;;; "cedet/ede/util.el" "cedet/semantic/analyze.el" "cedet/semantic/analyze/complete.el"
-;;;;;; "cedet/semantic/analyze/refs.el" "cedet/semantic/bovine.el"
-;;;;;; "cedet/semantic/bovine/c-by.el" "cedet/semantic/bovine/c.el"
-;;;;;; "cedet/semantic/bovine/el.el" "cedet/semantic/bovine/gcc.el"
-;;;;;; "cedet/semantic/bovine/make-by.el" "cedet/semantic/bovine/make.el"
-;;;;;; "cedet/semantic/bovine/scm-by.el" "cedet/semantic/bovine/scm.el"
-;;;;;; "cedet/semantic/complete.el" "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el"
-;;;;;; "cedet/semantic/db-find.el" "cedet/semantic/db-global.el"
-;;;;;; "cedet/semantic/db-mode.el" "cedet/semantic/db-typecache.el"
-;;;;;; "cedet/semantic/db.el" "cedet/semantic/debug.el" "cedet/semantic/decorate/include.el"
-;;;;;; "cedet/semantic/decorate/mode.el" "cedet/semantic/dep.el"
-;;;;;; "cedet/semantic/doc.el" "cedet/semantic/edit.el" "cedet/semantic/find.el"
-;;;;;; "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el"
+;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/cpp-root.el"
+;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el"
+;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el"
+;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/speedbar.el"
+;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el"
+;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el"
+;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el"
+;;;;;; "cedet/semantic/bovine/c.el" "cedet/semantic/bovine/el.el"
+;;;;;; "cedet/semantic/bovine/gcc.el" "cedet/semantic/bovine/make-by.el"
+;;;;;; "cedet/semantic/bovine/make.el" "cedet/semantic/bovine/scm-by.el"
+;;;;;; "cedet/semantic/bovine/scm.el" "cedet/semantic/complete.el"
+;;;;;; "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" "cedet/semantic/db-find.el"
+;;;;;; "cedet/semantic/db-global.el" "cedet/semantic/db-mode.el"
+;;;;;; "cedet/semantic/db-typecache.el" "cedet/semantic/db.el" "cedet/semantic/debug.el"
+;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el"
+;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el" "cedet/semantic/edit.el"
+;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el"
;;;;;; "cedet/semantic/grm-wy-boot.el" "cedet/semantic/html.el"
;;;;;; "cedet/semantic/ia-sb.el" "cedet/semantic/ia.el" "cedet/semantic/idle.el"
;;;;;; "cedet/semantic/imenu.el" "cedet/semantic/lex-spp.el" "cedet/semantic/lex.el"
@@ -40151,81 +40115,93 @@ Zone out, completely." t nil)
;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el"
;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el"
;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el"
-;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el"
-;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el"
+;;;;;; "cus-face.el" "cus-load.el" "cus-start.el" "custom.el" "dired-aux.el"
+;;;;;; "dired-x.el" "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el"
;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el"
-;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-custom.el"
-;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" "emacs-lisp/lisp-mode.el"
-;;;;;; "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" "emacs-lisp/map-ynp.el"
-;;;;;; "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el" "emacs-lisp/syntax.el"
-;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el"
-;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el"
-;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el"
-;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el"
-;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el"
-;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el"
-;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el"
-;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el"
-;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el"
-;;;;;; "erc/erc-status-sidebar.el" "erc/erc-track.el" "erc/erc-truncate.el"
-;;;;;; "erc/erc-xdcc.el" "eshell/em-alias.el" "eshell/em-banner.el"
-;;;;;; "eshell/em-basic.el" "eshell/em-cmpl.el" "eshell/em-dirs.el"
-;;;;;; "eshell/em-glob.el" "eshell/em-hist.el" "eshell/em-ls.el"
-;;;;;; "eshell/em-pred.el" "eshell/em-prompt.el" "eshell/em-rebind.el"
-;;;;;; "eshell/em-script.el" "eshell/em-smart.el" "eshell/em-term.el"
-;;;;;; "eshell/em-tramp.el" "eshell/em-unix.el" "eshell/em-xtra.el"
-;;;;;; "faces.el" "files.el" "font-core.el" "font-lock.el" "format.el"
+;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/debug-early.el" "emacs-lisp/easymenu.el"
+;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el"
+;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el"
+;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el"
+;;;;;; "emacs-lisp/syntax.el" "emacs-lisp/timer.el" "env.el" "epa-hook.el"
+;;;;;; "erc/erc-autoaway.el" "erc/erc-button.el" "erc/erc-capab.el"
+;;;;;; "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el"
+;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el"
+;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el"
+;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el"
+;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el"
+;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el"
+;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el"
+;;;;;; "erc/erc-stamp.el" "erc/erc-status-sidebar.el" "erc/erc-track.el"
+;;;;;; "erc/erc-truncate.el" "erc/erc-xdcc.el" "eshell/em-alias.el"
+;;;;;; "eshell/em-banner.el" "eshell/em-basic.el" "eshell/em-cmpl.el"
+;;;;;; "eshell/em-dirs.el" "eshell/em-glob.el" "eshell/em-hist.el"
+;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el"
+;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el"
+;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el"
+;;;;;; "eshell/em-xtra.el" "eshell/esh-groups.el" "faces.el" "files.el"
+;;;;;; "finder-inf.el" "font-core.el" "font-lock.el" "format.el"
;;;;;; "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el"
-;;;;;; "international/characters.el" "international/charscript.el"
-;;;;;; "international/cp51932.el" "international/emoji-zwj.el" "international/eucjp-ms.el"
+;;;;;; "international/characters.el" "international/charprop.el"
+;;;;;; "international/charscript.el" "international/cp51932.el"
+;;;;;; "international/emoji-labels.el" "international/emoji-zwj.el"
+;;;;;; "international/eucjp-ms.el" "international/idna-mapping.el"
;;;;;; "international/iso-transl.el" "international/mule-cmds.el"
-;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el"
-;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "keymap.el" "language/burmese.el"
-;;;;;; "language/cham.el" "language/chinese.el" "language/cyrillic.el"
-;;;;;; "language/czech.el" "language/english.el" "language/ethiopic.el"
-;;;;;; "language/european.el" "language/georgian.el" "language/greek.el"
-;;;;;; "language/hebrew.el" "language/indian.el" "language/japanese.el"
-;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el"
-;;;;;; "language/misc-lang.el" "language/romanian.el" "language/sinhala.el"
-;;;;;; "language/slovak.el" "language/tai-viet.el" "language/thai.el"
-;;;;;; "language/tibetan.el" "language/utf-8-lang.el" "language/vietnamese.el"
-;;;;;; "ldefs-boot.el" "leim/ja-dic/ja-dic.el" "leim/leim-list.el"
-;;;;;; "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el"
-;;;;;; "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" "leim/quail/ECDICT.el"
-;;;;;; "leim/quail/ETZY.el" "leim/quail/PY-b5.el" "leim/quail/PY.el"
-;;;;;; "leim/quail/Punct-b5.el" "leim/quail/Punct.el" "leim/quail/QJ-b5.el"
-;;;;;; "leim/quail/QJ.el" "leim/quail/SW.el" "leim/quail/TONEPY.el"
-;;;;;; "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" "leim/quail/arabic.el"
-;;;;;; "leim/quail/cham.el" "leim/quail/compose.el" "leim/quail/croatian.el"
-;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el"
-;;;;;; "leim/quail/emoji.el" "leim/quail/georgian.el" "leim/quail/greek.el"
-;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el"
-;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el"
-;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el"
-;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el"
-;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el"
-;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el"
-;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el"
-;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el"
-;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el"
-;;;;;; "loadup.el" "mail/blessmail.el" "mail/undigest.el" "menu-bar.el"
-;;;;;; "mh-e/mh-gnus.el" "minibuffer.el" "mouse.el" "newcomment.el"
-;;;;;; "obarray.el" "org/ob-core.el" "org/ob-lob.el" "org/ob-matlab.el"
-;;;;;; "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" "org/ol-irc.el"
-;;;;;; "org/ol.el" "org/org-archive.el" "org/org-attach.el" "org/org-clock.el"
-;;;;;; "org/org-colview.el" "org/org-compat.el" "org/org-datetree.el"
-;;;;;; "org/org-duration.el" "org/org-element.el" "org/org-feed.el"
-;;;;;; "org/org-footnote.el" "org/org-goto.el" "org/org-id.el" "org/org-indent.el"
-;;;;;; "org/org-install.el" "org/org-keys.el" "org/org-lint.el"
-;;;;;; "org/org-list.el" "org/org-macs.el" "org/org-mobile.el" "org/org-num.el"
-;;;;;; "org/org-plot.el" "org/org-refile.el" "org/org-table.el"
-;;;;;; "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" "org/ox-html.el"
-;;;;;; "org/ox-icalendar.el" "org/ox-latex.el" "org/ox-md.el" "org/ox-odt.el"
-;;;;;; "org/ox-org.el" "org/ox-publish.el" "org/ox-texinfo.el" "org/ox.el"
-;;;;;; "paren.el" "progmodes/elisp-mode.el" "progmodes/prog-mode.el"
-;;;;;; "ps-mule.el" "register.el" "replace.el" "rfn-eshadow.el"
-;;;;;; "select.el" "simple.el" "startup.el" "subdirs.el" "subr.el"
-;;;;;; "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el"
+;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el"
+;;;;;; "international/uni-brackets.el" "international/uni-category.el"
+;;;;;; "international/uni-combining.el" "international/uni-comment.el"
+;;;;;; "international/uni-confusable.el" "international/uni-decimal.el"
+;;;;;; "international/uni-decomposition.el" "international/uni-digit.el"
+;;;;;; "international/uni-lowercase.el" "international/uni-mirrored.el"
+;;;;;; "international/uni-name.el" "international/uni-numeric.el"
+;;;;;; "international/uni-old-name.el" "international/uni-scripts.el"
+;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el"
+;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el"
+;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el"
+;;;;;; "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" "language/cham.el"
+;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el"
+;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el"
+;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el"
+;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el"
+;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el"
+;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el"
+;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el"
+;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el"
+;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el"
+;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el"
+;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el"
+;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el"
+;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el"
+;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el"
+;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/cham.el"
+;;;;;; "leim/quail/compose.el" "leim/quail/croatian.el" "leim/quail/cyril-jis.el"
+;;;;;; "leim/quail/cyrillic.el" "leim/quail/czech.el" "leim/quail/emoji.el"
+;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el"
+;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el"
+;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el"
+;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el"
+;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el"
+;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el"
+;;;;;; "leim/quail/rfc1345.el" "leim/quail/sami.el" "leim/quail/sgml-input.el"
+;;;;;; "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el"
+;;;;;; "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" "leim/quail/vntelex.el"
+;;;;;; "leim/quail/vnvni.el" "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el"
+;;;;;; "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" "minibuffer.el"
+;;;;;; "mouse.el" "newcomment.el" "obarray.el" "org/ob-core.el"
+;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el"
+;;;;;; "org/ol-bbdb.el" "org/ol-irc.el" "org/ol.el" "org/org-archive.el"
+;;;;;; "org/org-attach.el" "org/org-clock.el" "org/org-colview.el"
+;;;;;; "org/org-compat.el" "org/org-datetree.el" "org/org-duration.el"
+;;;;;; "org/org-element.el" "org/org-feed.el" "org/org-footnote.el"
+;;;;;; "org/org-goto.el" "org/org-id.el" "org/org-indent.el" "org/org-install.el"
+;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el"
+;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el"
+;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el"
+;;;;;; "org/ox-html.el" "org/ox-icalendar.el" "org/ox-latex.el"
+;;;;;; "org/ox-md.el" "org/ox-odt.el" "org/ox-org.el" "org/ox-publish.el"
+;;;;;; "org/ox-texinfo.el" "org/ox.el" "paren.el" "progmodes/elisp-mode.el"
+;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "register.el" "replace.el"
+;;;;;; "rfn-eshadow.el" "select.el" "simple.el" "startup.el" "subdirs.el"
+;;;;;; "subr.el" "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el"
;;;;;; "textmodes/page.el" "textmodes/paragraphs.el" "textmodes/reftex-auc.el"
;;;;;; "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" "textmodes/reftex-global.el"
;;;;;; "textmodes/reftex-index.el" "textmodes/reftex-parse.el" "textmodes/reftex-ref.el"
diff --git a/lisp/leim/quail/compose.el b/lisp/leim/quail/compose.el
index 2aa8ae78fe7..60c73d7dff8 100644
--- a/lisp/leim/quail/compose.el
+++ b/lisp/leim/quail/compose.el
@@ -464,9 +464,9 @@ Examples:
("2^" ?²)
("^3" ?³)
("3^" ?³)
- ("mu" ?µ)
- ("/u" ?µ)
- ("u/" ?µ)
+ ("mu" ?μ)
+ ("/u" ?μ)
+ ("u/" ?μ)
("^1" ?¹)
("1^" ?¹)
("^_o" ?º)
diff --git a/lisp/leim/quail/symbol-ksc.el b/lisp/leim/quail/symbol-ksc.el
index 042465697a1..d440058902a 100644
--- a/lisp/leim/quail/symbol-ksc.el
+++ b/lisp/leim/quail/symbol-ksc.el
@@ -39,7 +39,7 @@
"한글심벌입력표:
【(】괄호열기【arrow】화살【sex】♂♀【index】첨자 【accent】악센트
【)】괄호닫기【music】음악【dot】점 【quote】따옴표【xtext】§※¶¡¿
- 【Unit】℃Å¢℉【math】수학기호【pic】상형문자【line】선문자
+ 【Unit】℃Å¢℉【math】수학기호【pic】상형문자【line】선문자
【unit】단위 【frac】분수 【textline】­―∥\∼
【wn】㈜【ks】㉿【No】№【㏇】㏇ 【dag】† 【ddag】‡【percent】‰
【am】㏂【pm】㏘【™】™【Tel】℡【won】₩ 【yen】¥ 【pound】£
@@ -65,7 +65,7 @@
("dot" "·‥…¨ː")
("quote" "、。〃‘’“”°′″´˝")
("textline" "­―∥\∼")
- ("Unit" "℃Å¢℉")
+ ("Unit" "℃Å¢℉")
("sex" "♂♀")
("accent" "~ˇ˘˚˙¸˛")
("percent" "‰")
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 81172c584d7..6ca699f9016 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -196,11 +196,10 @@
(setq definition-prefixes new))
(load "button") ;After loaddefs, because of define-minor-mode!
-(load "emacs-lisp/nadvice")
(load "emacs-lisp/cl-preloaded")
+(load "emacs-lisp/oclosure") ;Used by cl-generic
(load "obarray") ;abbrev.el is implemented in terms of obarrays.
(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.
-(load "simple")
(load "help")
@@ -251,6 +250,8 @@
(let ((max-specpdl-size (max max-specpdl-size 1800)))
;; A particularly demanding file to load; 1600 does not seem to be enough.
(load "emacs-lisp/cl-generic"))
+(load "simple")
+(load "emacs-lisp/nadvice")
(load "minibuffer") ;Needs cl-generic (and define-minor-mode).
(load "frame")
(load "startup")
diff --git a/lisp/macros.el b/lisp/macros.el
index 35d34d2e337..0baf3804332 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -46,6 +46,16 @@
" ")
?\]))
+(defun macro--string-to-vector (str)
+ "Convert an old-style string key sequence to the vector form."
+ (let ((vec (string-to-vector str)))
+ (unless (multibyte-string-p str)
+ (dotimes (i (length vec))
+ (let ((k (aref vec i)))
+ (when (> k 127)
+ (setf (aref vec i) (+ k ?\M-\C-@ -128))))))
+ vec))
+
;;;###autoload
(defun insert-kbd-macro (macroname &optional keys)
"Insert in buffer the definition of kbd macro MACRONAME, as Lisp code.
@@ -72,66 +82,31 @@ use this command, and then save the file."
(setq macroname 'last-kbd-macro definition last-kbd-macro)
(insert "(setq "))
(setq definition (symbol-function macroname))
- (insert "(fset '"))
+ ;; Prefer `defalias' over `fset' since it additionally keeps
+ ;; track of the file where the users added it, and it interacts
+ ;; better with `advice-add' (and hence things like ELP).
+ (insert "(defalias '"))
(prin1 macroname (current-buffer))
(insert "\n ")
- (if (stringp definition)
- (let ((beg (point)) end)
- (prin1 definition (current-buffer))
- (setq end (point-marker))
- (goto-char beg)
- (while (< (point) end)
- (let ((char (following-char)))
- (cond ((= char 0)
- (delete-region (point) (1+ (point)))
- (insert "\\C-@"))
- ((< char 27)
- (delete-region (point) (1+ (point)))
- (insert "\\C-" (+ 96 char)))
- ((= char ?\C-\\)
- (delete-region (point) (1+ (point)))
- (insert "\\C-\\\\"))
- ((< char 32)
- (delete-region (point) (1+ (point)))
- (insert "\\C-" (+ 64 char)))
- ((< char 127)
- (forward-char 1))
- ((= char 127)
- (delete-region (point) (1+ (point)))
- (insert "\\C-?"))
- ((= char 128)
- (delete-region (point) (1+ (point)))
- (insert "\\M-\\C-@"))
- ((= char (aref "\M-\C-\\" 0))
- (delete-region (point) (1+ (point)))
- (insert "\\M-\\C-\\\\"))
- ((< char 155)
- (delete-region (point) (1+ (point)))
- (insert "\\M-\\C-" (- char 32)))
- ((< char 160)
- (delete-region (point) (1+ (point)))
- (insert "\\M-\\C-" (- char 64)))
- ((= char (aref "\M-\\" 0))
- (delete-region (point) (1+ (point)))
- (insert "\\M-\\\\"))
- ((< char 255)
- (delete-region (point) (1+ (point)))
- (insert "\\M-" (- char 128)))
- ((= char 255)
- (delete-region (point) (1+ (point)))
- (insert "\\M-\\C-?"))))))
- (if (vectorp definition)
- (macros--insert-vector-macro definition)
- (pcase (kmacro-extract-lambda definition)
- (`(,vecdef ,counter ,format)
- (insert "(kmacro-lambda-form ")
- (macros--insert-vector-macro vecdef)
- (insert " ")
- (prin1 counter (current-buffer))
- (insert " ")
- (prin1 format (current-buffer))
- (insert ")"))
- (_ (prin1 definition (current-buffer))))))
+ (when (stringp definition)
+ (setq definition (macro--string-to-vector definition)))
+ (if (vectorp definition)
+ (setq definition (kmacro definition)))
+ (if (kmacro-p definition)
+ (let ((vecdef (kmacro--keys definition))
+ (counter (kmacro--counter definition))
+ (format (kmacro--format definition)))
+ (insert "(kmacro ")
+ (prin1 (key-description vecdef) (current-buffer))
+ ;; FIXME: Do we really want to store the counter?
+ (unless (and (equal counter 0) (equal format "%d"))
+ (insert " ")
+ (prin1 counter (current-buffer))
+ (insert " ")
+ (prin1 format (current-buffer)))
+ (insert ")"))
+ ;; FIXME: Shouldn't this signal an error?
+ (prin1 definition (current-buffer)))
(insert ")\n")
(if keys
(let ((keys (or (and (symbol-function macroname)
diff --git a/lisp/mail/mail-parse.el b/lisp/mail/mail-parse.el
index 23894e59b77..ec719850e2e 100644
--- a/lisp/mail/mail-parse.el
+++ b/lisp/mail/mail-parse.el
@@ -76,7 +76,8 @@
The return value is a list with mail/name pairs."
(delq nil
(mapcar (lambda (elem)
- (or (mail-header-parse-address elem)
+ (or (ignore-errors
+ (mail-header-parse-address elem))
(mail-header-parse-address-lax elem)))
(mail-header-parse-addresses string t))))
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index 76a32724c08..79f421bdcd6 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -796,17 +796,14 @@ directly."
((string-match "text/" content-type)
(setq type 'text))
((string-match "image/\\(.*\\)" content-type)
- (setq type (image-type-from-file-name
+ (setq type (image-supported-file-p
(concat "." (match-string 1 content-type))))
- (if (and (boundp 'image-types)
- (memq type image-types)
- (image-type-available-p type))
- (if (and rmail-mime-show-images
- (not (eq rmail-mime-show-images 'button))
- (or (not (numberp rmail-mime-show-images))
- (< size rmail-mime-show-images)))
- (setq to-show t))
- (setq type nil))))
+ (when (and type
+ rmail-mime-show-images
+ (not (eq rmail-mime-show-images 'button))
+ (or (not (numberp rmail-mime-show-images))
+ (< size rmail-mime-show-images)))
+ (setq to-show t))))
(setcar bulk-data size)
(setcdr bulk-data type)
to-show))
diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el
index 03e77a83ce3..c6d29bc4e77 100644
--- a/lisp/mail/undigest.el
+++ b/lisp/mail/undigest.el
@@ -41,7 +41,8 @@ You may need to customize it for local needs."
(defconst rmail-digest-methods
- '(rmail-digest-parse-mime
+ '(rmail-digest-parse-mixed-mime
+ rmail-digest-parse-mime
rmail-digest-parse-rfc1153strict
rmail-digest-parse-rfc1153sloppy
rmail-digest-parse-rfc934)
@@ -52,6 +53,53 @@ A function returns nil if it cannot parse the digest. If it can, it
returns a list of cons pairs containing the start and end positions of
each undigestified message as markers.")
+(defun rmail-content-type-boundary (type)
+ "If Content-type is of type TYPE, return its boundary; otherwise, return nil."
+ (goto-char (point-min))
+ (let ((head-end (save-excursion (search-forward "\n\n" nil t) (point))))
+ (when (re-search-forward
+ (concat "^Content-type: " type ";"
+ "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]")
+ head-end t)
+ (match-string 1))))
+
+(defun rmail-digest-parse-mixed-mime ()
+ "Like `rmail-digest-parse-mime', but for multipart/mixed messages."
+ (when-let ((boundary (rmail-content-type-boundary "multipart/mixed")))
+ (let ((global-sep (concat "\n--" boundary))
+ (digest (concat "^Content-type: multipart/digest;"
+ "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]"))
+ result)
+ (search-forward global-sep nil t)
+ (while (not (or result (eobp)))
+ ;; For each part, see if it is a multipart/digest.
+ (let* ((limit (save-excursion (search-forward global-sep nil 'move)
+ (point)))
+ (beg (and (re-search-forward digest limit t)
+ (match-beginning 0)))
+ digest-sep)
+ (when (and beg
+ (setq digest-sep (concat "\n--" (match-string 1)))
+ ;; Search for 1st sep.
+ (search-forward digest-sep nil t))
+ ;; Skip body part headers.
+ (search-forward "\n\n" nil t)
+ ;; Push the 1st message.
+ (push (cons (copy-marker beg) (copy-marker (point-marker) t))
+ result)
+ ;; Push the rest of the messages.
+ (let ((start (make-marker))
+ done)
+ (while (and (search-forward digest-sep limit 'move) (not done))
+ (move-marker start (match-beginning 0))
+ (and (looking-at "--$") (setq done t))
+ (search-forward "\n\n")
+ (push (cons (copy-marker start)
+ (copy-marker (point-marker) t))
+ result))))
+ (goto-char limit)))
+ (nreverse result))))
+
(defun rmail-digest-parse-mime ()
(goto-char (point-min))
(when (let ((head-end (progn (search-forward "\n\n" nil t) (point))))
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index ab64928fe76..d8c8c760f78 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -606,7 +606,8 @@
"Insert the clipboard contents, or the last stretch of killed text."
(interactive "*")
(let ((select-enable-clipboard t)
- ;; Ensure that we defeat the DWIM login in `gui-selection-value'.
+ ;; Ensure that we defeat the DWIM logic in `gui-selection-value'
+ ;; (i.e., that gui--clipboard-selection-unchanged-p returns nil).
(gui--last-selected-text-clipboard nil))
(yank)))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 36b8d808417..f60af482da2 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -894,11 +894,23 @@ If the current buffer is not a minibuffer, erase its entire contents."
(defcustom completion-auto-help t
"Non-nil means automatically provide help for invalid completion input.
-If the value is t the *Completions* buffer is displayed whenever completion
+If the value is t, the *Completions* buffer is displayed whenever completion
is requested but cannot be done.
If the value is `lazy', the *Completions* buffer is only displayed after
-the second failed attempt to complete."
- :type '(choice (const nil) (const t) (const lazy)))
+the second failed attempt to complete.
+If the value is 'always', the *Completions* buffer is always shown
+after a completion attempt, and the list of completions is updated if
+already visible.
+If the value is 'visible', the *Completions* buffer is displayed
+whenever completion is requested but cannot be done for the first time,
+but remains visible thereafter, and the list of completions in it is
+updated for subsequent attempts to complete.."
+ :type '(choice (const :tag "Don't show" nil)
+ (const :tag "Show only when cannot complete" t)
+ (const :tag "Show after second failed completion attempt" lazy)
+ (const :tag
+ "Leave visible after first failed completion" visible)
+ (const :tag "Always visible" always)))
(defvar completion-styles-alist
'((emacs21
@@ -1343,16 +1355,18 @@ when the buffer's text is already an exact match."
(completion--cache-all-sorted-completions beg end comps)
(minibuffer-force-complete beg end))
(completed
- ;; We could also decide to refresh the completions,
- ;; if they're displayed (and assuming there are
- ;; completions left).
- (minibuffer-hide-completions)
- (if exact
- ;; If completion did not put point at end of field,
- ;; it's a sign that completion is not finished.
- (completion--done completion
- (if (< comp-pos (length completion))
- 'exact 'unknown))))
+ (cond
+ ((pcase completion-auto-help
+ ('visible (get-buffer-window "*Completions*" 0))
+ ('always t))
+ (minibuffer-completion-help beg end))
+ (t (minibuffer-hide-completions)
+ (when exact
+ ;; If completion did not put point at end of field,
+ ;; it's a sign that completion is not finished.
+ (completion--done completion
+ (if (< comp-pos (length completion))
+ 'exact 'unknown))))))
;; Show the completion table, if requested.
((not exact)
(if (pcase completion-auto-help
@@ -1396,18 +1410,26 @@ scroll the window of possible completions."
;; and this command is repeated, scroll that window.
((and (window-live-p minibuffer-scroll-window)
(eq t (frame-visible-p (window-frame minibuffer-scroll-window))))
- (let ((window minibuffer-scroll-window)
- (reverse (equal (this-command-keys) [backtab])))
+ (let ((window minibuffer-scroll-window))
(with-current-buffer (window-buffer window)
- (if (pos-visible-in-window-p (if reverse (point-min) (point-max)) window)
- ;; If end or beginning is in view, scroll up to the
- ;; beginning or end respectively.
- (if reverse
- (set-window-point window (point-max))
- (set-window-start window (point-min) nil))
- ;; Else scroll down one screen.
- (with-selected-window window
- (if reverse (scroll-down) (scroll-up))))
+ (cond
+ ;; Here this is possible only when second-tab, so jump now.
+ (completion-auto-select
+ (switch-to-completions))
+ ;; Reverse tab
+ ((equal (this-command-keys) [backtab])
+ (if (pos-visible-in-window-p (point-min) window)
+ ;; If beginning is in view, scroll up to the end.
+ (set-window-point window (point-max))
+ ;; Else scroll down one screen.
+ (with-selected-window window (scroll-down))))
+ ;; Normal tab
+ (t
+ (if (pos-visible-in-window-p (point-max) window)
+ ;; If end is in view, scroll up to the end.
+ (set-window-start window (point-min) nil)
+ ;; Else scroll down one screen.
+ (with-selected-window window (scroll-up)))))
nil)))
;; If we're cycling, keep on cycling.
((and completion-cycling completion-all-sorted-completions)
@@ -1842,6 +1864,17 @@ Return nil if there is no valid completion, else t."
This face is only used if the strings used for completions
doesn't already specify a face.")
+(defface completions-highlight
+ '((t :inherit highlight))
+ "Default face for highlighting the current completion candidate."
+ :version "29.1")
+
+(defcustom completions-highlight-face 'completions-highlight
+ "A face name to highlight the current completion candidate.
+If the value is nil, no highlighting is performed."
+ :type '(choice (const nil) face)
+ :version "29.1")
+
(defcustom completions-format 'horizontal
"Define the appearance and sorting of completions.
If the value is `vertical', display completions sorted vertically
@@ -1861,6 +1894,17 @@ completions."
:type 'boolean
:version "28.1")
+(defcustom completions-header-format
+ (propertize "%s possible completions:\n"
+ 'face 'shadow
+ :help "Please select a completion")
+ "Format of completions header.
+It may contain one %s to show the total count of completions.
+When nil, no header is shown."
+ :type '(choice (const :tag "No header" nil)
+ (string :tag "Header format string"))
+ :version "29.1")
+
(defun completion--insert-strings (strings &optional group-fun)
"Insert a list of STRINGS into the current buffer.
The candidate strings are inserted into the buffer depending on the
@@ -2000,7 +2044,8 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a
(when title
(insert (format completions-group-format title) "\n")))))
(completion--insert str group-fun)
- (insert "\n")))))
+ (insert "\n")))
+ (delete-char -1)))
(defun completion--insert (str group-fun)
(if (not (consp str))
@@ -2012,7 +2057,7 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a
(funcall group-fun str 'transform)
str))
(point))
- `(mouse-face highlight completion--string ,str))
+ `(mouse-face highlight cursor-face ,completions-highlight-face completion--string ,str))
;; If `str' is a list that has 2 elements,
;; then the second element is a suffix annotation.
;; If `str' has 3 elements, then the second element
@@ -2123,10 +2168,9 @@ candidates."
(with-current-buffer standard-output
(goto-char (point-max))
- (if (null completions)
- (insert "There are no possible completions of what you have typed.")
- (insert "Possible completions are:\n")
- (completion--insert-strings completions group-fun))))
+ (when completions-header-format
+ (insert (format completions-header-format (length completions))))
+ (completion--insert-strings completions group-fun)))
(run-hooks 'completion-setup-hook)
nil)
@@ -2198,6 +2242,19 @@ variables.")
(equal pre-msg (and exit-fun (current-message))))
(completion--message message))))
+(defcustom completions-max-height nil
+ "Maximum height for *Completions* buffer window."
+ :type '(choice (const nil) natnum)
+ :version "29.1")
+
+(defun completions--fit-window-to-buffer (&optional win &rest _)
+ "Resize *Completions* buffer window."
+ (if temp-buffer-resize-mode
+ (let ((temp-buffer-max-height (or completions-max-height
+ temp-buffer-max-height)))
+ (resize-temp-buffer-window win))
+ (fit-window-to-buffer win completions-max-height)))
+
(defun minibuffer-completion-help (&optional start end)
"Display a list of possible completions of the current minibuffer contents."
(interactive)
@@ -2227,6 +2284,9 @@ variables.")
(let* ((last (last completions))
(base-size (or (cdr last) 0))
(prefix (unless (zerop base-size) (substring string 0 base-size)))
+ (base-prefix (buffer-substring (minibuffer--completion-prompt-end)
+ (+ start base-size)))
+ (base-suffix (buffer-substring (point) (point-max)))
(all-md (completion--metadata (buffer-substring-no-properties
start (point))
base-size md
@@ -2261,9 +2321,7 @@ variables.")
,(if (eq (selected-window) (minibuffer-window))
'display-buffer-at-bottom
'display-buffer-below-selected))
- ,(if temp-buffer-resize-mode
- '(window-height . resize-temp-buffer-window)
- '(window-height . fit-window-to-buffer))
+ (window-height . completions--fit-window-to-buffer)
,(when temp-buffer-resize-mode
'(preserve-size . (nil . t)))
(body-function
@@ -2320,20 +2378,28 @@ variables.")
;; completion-all-completions does not give us the
;; necessary information.
end))
+ (setq-local completion-base-affixes
+ (list base-prefix base-suffix))
(setq-local completion-list-insert-choice-function
(let ((ctable minibuffer-completion-table)
(cpred minibuffer-completion-predicate)
(cprops completion-extra-properties))
(lambda (start end choice)
- (unless (or (zerop (length prefix))
- (equal prefix
- (buffer-substring-no-properties
- (max (point-min)
- (- start (length prefix)))
- start)))
- (message "*Completions* out of date"))
- ;; FIXME: Use `md' to do quoting&terminator here.
- (completion--replace start end choice)
+ (if (and (stringp start) (stringp end))
+ (progn
+ (delete-minibuffer-contents)
+ (insert start choice)
+ ;; Keep point after completion before suffix
+ (save-excursion (insert end)))
+ (unless (or (zerop (length prefix))
+ (equal prefix
+ (buffer-substring-no-properties
+ (max (point-min)
+ (- start (length prefix)))
+ start)))
+ (message "*Completions* out of date"))
+ ;; FIXME: Use `md' to do quoting&terminator here.
+ (completion--replace start end choice))
(let* ((minibuffer-completion-table ctable)
(minibuffer-completion-predicate cpred)
(completion-extra-properties cprops)
@@ -2354,6 +2420,7 @@ variables.")
"Get rid of an out-of-date *Completions* buffer."
;; FIXME: We could/should use minibuffer-scroll-window here, but it
;; can also point to the minibuffer-parent-window, so it's a bit tricky.
+ (interactive)
(let ((win (get-buffer-window "*Completions*" 0)))
(if win (with-selected-window win (bury-buffer)))))
@@ -2681,7 +2748,10 @@ The completion method is determined by `completion-at-point-functions'."
"?" #'minibuffer-completion-help
"<prior>" #'switch-to-completions
"M-v" #'switch-to-completions
- "M-g M-c" #'switch-to-completions)
+ "M-g M-c" #'switch-to-completions
+ "M-<up>" #'minibuffer-previous-completion
+ "M-<down>" #'minibuffer-next-completion
+ "M-RET" #'minibuffer-choose-completion)
(defvar-keymap minibuffer-local-must-match-map
:doc "Local keymap for minibuffer input with completion, for exact match."
@@ -4271,6 +4341,66 @@ the minibuffer was activated, and execute the forms."
(with-minibuffer-selected-window
(scroll-other-window-down arg)))
+(defmacro with-minibuffer-completions-window (&rest body)
+ "Execute the forms in BODY from the minibuffer in its completions window.
+When used in a minibuffer window, select the window with completions,
+and execute the forms."
+ (declare (indent 0) (debug t))
+ `(let ((window (or (get-buffer-window "*Completions*" 0)
+ ;; Make sure we have a completions window.
+ (progn (minibuffer-completion-help)
+ (get-buffer-window "*Completions*" 0)))))
+ (when window
+ (with-selected-window window
+ ,@body))))
+
+(defcustom minibuffer-completion-auto-choose t
+ "Non-nil means to automatically insert completions to the minibuffer.
+When non-nil, then `minibuffer-next-completion' and
+`minibuffer-previous-completion' will insert the completion
+selected by these commands to the minibuffer."
+ :type 'boolean
+ :version "29.1")
+
+(defun minibuffer-next-completion (&optional n)
+ "Run `next-completion' from the minibuffer in its completions window.
+When `minibuffer-completion-auto-choose' is non-nil, then also
+insert the selected completion to the minibuffer."
+ (interactive "p")
+ (with-minibuffer-completions-window
+ (when completions-highlight-face
+ (setq-local cursor-face-highlight-nonselected-window t))
+ (next-completion (or n 1))
+ (when minibuffer-completion-auto-choose
+ (let ((completion-use-base-affixes t))
+ (choose-completion nil t t)))))
+
+(defun minibuffer-previous-completion (&optional n)
+ "Run `previous-completion' from the minibuffer in its completions window.
+When `minibuffer-completion-auto-choose' is non-nil, then also
+insert the selected completion to the minibuffer."
+ (interactive "p")
+ (with-minibuffer-completions-window
+ (when completions-highlight-face
+ (setq-local cursor-face-highlight-nonselected-window t))
+ (previous-completion (or n 1))
+ (when minibuffer-completion-auto-choose
+ (let ((completion-use-base-affixes t))
+ (choose-completion nil t t)))))
+
+(defun minibuffer-choose-completion (&optional no-exit no-quit)
+ "Run `choose-completion' from the minibuffer in its completions window.
+With prefix argument NO-EXIT, insert the completion at point to the
+minibuffer, but don't exit the minibuffer. When the prefix argument
+is not provided, then whether to exit the minibuffer depends on the value
+of `completion-no-auto-exit'.
+If NO-QUIT is non-nil, insert the completion at point to the
+minibuffer, but don't quit the completions window."
+ (interactive "P")
+ (with-minibuffer-completions-window
+ (let ((completion-use-base-affixes t))
+ (choose-completion nil no-exit no-quit))))
+
(defcustom minibuffer-default-prompt-format " (default %s)"
"Format string used to output \"default\" values.
When prompting for input, there will often be a default value,
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 93c89de91c2..b66cfad4878 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -97,6 +97,15 @@ point at the click position."
:type 'boolean
:version "22.1")
+(defcustom mouse-drag-and-drop-region-scroll-margin nil
+ "If non-nil, the scroll margin inside a window when dragging text.
+If the mouse moves this many lines close to the top or bottom of
+a window while dragging text, then that window will be scrolled
+down and up respectively."
+ :type '(choice (const :tag "Don't scroll during mouse movement")
+ (integer :tag "This many lines from window top or bottom"))
+ :version "29.1")
+
(defvar mouse--last-down nil)
(defun mouse--down-1-maybe-follows-link (&optional _prompt)
@@ -2998,6 +3007,9 @@ Call `tooltip-show-help-non-mode' instead on non-graphical displays."
(x-show-tip tooltip)
(tooltip-show-help-non-mode tooltip)))
+(declare-function x-hide-tip "xfns.c")
+(declare-function x-show-tip "xfns.c")
+
(defun mouse-drag-and-drop-region-hide-tooltip ()
"Hide any tooltip currently displayed.
Call `tooltip-show-help-non-mode' to clear the echo area message
@@ -3034,6 +3046,10 @@ is copied instead of being cut."
(cdr bounds)))
(region-bounds)))
(region-noncontiguous (region-noncontiguous-p))
+ ;; Whether or not some text was ``cut'' from Emacs to another
+ ;; program and the cleaanup code should not try modifying the
+ ;; region.
+ drag-was-cross-program
point-to-paste
point-to-paste-read-only
window-to-paste
@@ -3045,7 +3061,8 @@ is copied instead of being cut."
value-selection ; This remains nil when event was "click".
text-tooltip
states
- window-exempt)
+ window-exempt
+ drag-again-mouse-position)
;; STATES stores for each window on this frame its start and point
;; positions so we can restore them on all windows but for the one
@@ -3069,7 +3086,18 @@ is copied instead of being cut."
(ignore-errors
(catch 'cross-program-drag
(track-mouse
- (setq track-mouse 'dropping)
+ (setq track-mouse (if mouse-drag-and-drop-region-cross-program
+ ;; When `track-mouse' is `drop', we
+ ;; get events with a posn-window of
+ ;; the grabbed frame even if some
+ ;; window is between that and the
+ ;; pointer. This makes dragging to a
+ ;; window on top of a frame
+ ;; impossible. With this value of
+ ;; `track-mouse', no frame is returned
+ ;; in that particular case.
+ 'drag-source
+ 'drop))
;; When event was "click" instead of "drag", skip loop.
(while (progn
(setq event (read-key)) ; read-event or read-key
@@ -3077,6 +3105,37 @@ is copied instead of being cut."
;; Handle `mouse-autoselect-window'.
(memq (car event) '(select-window switch-frame))))
(catch 'drag-again
+ ;; If the mouse is in the drag scroll margin, scroll
+ ;; either up or down depending on which margin it is in.
+ (when mouse-drag-and-drop-region-scroll-margin
+ (let* ((row (cdr (posn-col-row (event-end event))))
+ (window (when (windowp (posn-window (event-end event)))
+ (posn-window (event-end event))))
+ (text-height (when window
+ (window-text-height window)))
+ ;; Make sure it's possible to scroll both up
+ ;; and down if the margin is too large for the
+ ;; window.
+ (margin (when text-height
+ (min (/ text-height 3)
+ mouse-drag-and-drop-region-scroll-margin))))
+ (when (windowp window)
+ ;; At 2 lines, the window becomes too small for any
+ ;; meaningful scrolling.
+ (unless (<= text-height 2)
+ ;; We could end up at the beginning or end of the
+ ;; buffer.
+ (ignore-errors
+ (cond
+ ;; Inside the bottom scroll margin, scroll up.
+ ((> row (- text-height margin))
+ (with-selected-window window
+ (scroll-up 1)))
+ ;; Inside the top scroll margin, scroll down.
+ ((< row margin)
+ (with-selected-window window
+ (scroll-down 1)))))))))
+
;; Obtain the dragged text in region. When the loop was
;; skipped, value-selection remains nil.
(unless value-selection
@@ -3104,34 +3163,66 @@ is copied instead of being cut."
(when (and mouse-drag-and-drop-region-cross-program
(display-graphic-p)
(fboundp 'x-begin-drag)
- (framep (posn-window (event-end event)))
- (let ((location (posn-x-y (event-end event)))
- (frame (posn-window (event-end event))))
- (or (< (car location) 0)
- (< (cdr location) 0)
- (> (car location)
- (frame-pixel-width frame))
- (> (cdr location)
- (frame-pixel-height frame)))))
+ (or (and (framep (posn-window (event-end event)))
+ (let ((location (posn-x-y (event-end event)))
+ (frame (posn-window (event-end event))))
+ (or (< (car location) 0)
+ (< (cdr location) 0)
+ (> (car location)
+ (frame-pixel-width frame))
+ (> (cdr location)
+ (frame-pixel-height frame)))))
+ (and (or (not drag-again-mouse-position)
+ (let ((mouse-position (mouse-absolute-pixel-position)))
+ (or (< 5 (abs (- (car drag-again-mouse-position)
+ (car mouse-position))))
+ (< 5 (abs (- (cdr drag-again-mouse-position)
+ (cdr mouse-position)))))))
+ (not (posn-window (event-end event))))))
+ (setq drag-again-mouse-position nil)
(mouse-drag-and-drop-region-hide-tooltip)
(gui-set-selection 'XdndSelection value-selection)
(let ((drag-action-or-frame
- (x-begin-drag '("UTF8_STRING" "text/plain"
- "text/plain;charset=utf-8"
- "STRING" "TEXT" "COMPOUND_TEXT")
- (if mouse-drag-and-drop-region-cut-when-buffers-differ
- 'XdndActionMove
- 'XdndActionCopy)
- (posn-window (event-end event)) t)))
+ (condition-case nil
+ (x-begin-drag '("UTF8_STRING" "text/plain"
+ "text/plain;charset=utf-8"
+ "STRING" "TEXT" "COMPOUND_TEXT")
+ (if mouse-drag-and-drop-region-cut-when-buffers-differ
+ 'XdndActionMove
+ 'XdndActionCopy)
+ (posn-window (event-end event)) 'now
+ ;; On platforms where we know
+ ;; `return-frame' doesn't
+ ;; work, allow dropping on
+ ;; the drop frame.
+ (eq window-system 'haiku))
+ (quit nil))))
(when (framep drag-action-or-frame)
+ ;; With some window managers `x-begin-drag'
+ ;; returns a frame sooner than `mouse-position'
+ ;; will return one, due to over-wide frame windows
+ ;; being drawn by the window manager. To avoid
+ ;; that, we just require the mouse move a few
+ ;; pixels before beginning another cross-program
+ ;; drag.
+ (setq drag-again-mouse-position
+ (mouse-absolute-pixel-position))
(throw 'drag-again nil))
- (when (eq drag-action-or-frame 'XdndActionMove)
- ;; Remove the dragged text from source buffer like
- ;; operation `cut'.
- (dolist (overlay mouse-drag-and-drop-overlays)
- (delete-region (overlay-start overlay)
- (overlay-end overlay))))
+ (let ((min-char (point)))
+ (when (eq drag-action-or-frame 'XdndActionMove)
+ ;; Remove the dragged text from source buffer like
+ ;; operation `cut'.
+ (dolist (overlay mouse-drag-and-drop-overlays)
+ (when (< min-char (min (overlay-start overlay)
+ (overlay-end overlay)))
+ (setq min-char (min (overlay-start overlay)
+ (overlay-end overlay))))
+ (delete-region (overlay-start overlay)
+ (overlay-end overlay)))
+ (goto-char min-char)
+ (setq deactivate-mark t)
+ (setq drag-was-cross-program t)))
(when (eq drag-action-or-frame 'XdndActionCopy)
;; Set back the dragged text as region on source buffer
@@ -3238,87 +3329,88 @@ is copied instead of being cut."
;; Do not modify any buffers when event is "click",
;; "drag but negligible", or "drag to read-only".
- (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ
- (if no-modifier-on-drop
- mouse-drag-and-drop-region-cut-when-buffers-differ
- (not mouse-drag-and-drop-region-cut-when-buffers-differ)))
- (wanna-paste-to-same-buffer (equal buffer-to-paste buffer))
- (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer
- no-modifier-on-drop))
- (wanna-cut-on-other-buffer
- (and (not wanna-paste-to-same-buffer)
- mouse-drag-and-drop-region-cut-when-buffers-differ))
- (cannot-paste (or point-to-paste-read-only
- (when (or wanna-cut-on-same-buffer
- wanna-cut-on-other-buffer)
- text-from-read-only))))
-
- (cond
- ;; Move point within region.
- (clicked
- (deactivate-mark)
- (mouse-set-point event))
- ;; Undo operation. Set back the original text as region.
- ((or (and drag-but-negligible
- no-modifier-on-drop)
- cannot-paste)
- ;; Inform user either source or destination buffer cannot be modified.
- (when (and (not drag-but-negligible)
- cannot-paste)
- (message "Buffer is read-only"))
-
- ;; Select source window back and restore region.
- ;; (set-window-point window point)
- (select-window window)
- (goto-char point)
- (setq deactivate-mark nil)
- (activate-mark)
- (when region-noncontiguous
- (rectangle-mark-mode)))
- ;; Modify buffers.
- (t
- ;; * DESTINATION BUFFER::
- ;; Insert the text to destination buffer under mouse.
- (select-window window-to-paste)
- (setq window-exempt window-to-paste)
- (goto-char point-to-paste)
- (push-mark)
- (insert-for-yank value-selection)
-
- ;; On success, set the text as region on destination buffer.
- (when (not (equal (mark) (point)))
+ (unless drag-was-cross-program
+ (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ
+ (if no-modifier-on-drop
+ mouse-drag-and-drop-region-cut-when-buffers-differ
+ (not mouse-drag-and-drop-region-cut-when-buffers-differ)))
+ (wanna-paste-to-same-buffer (equal buffer-to-paste buffer))
+ (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer
+ no-modifier-on-drop))
+ (wanna-cut-on-other-buffer
+ (and (not wanna-paste-to-same-buffer)
+ mouse-drag-and-drop-region-cut-when-buffers-differ))
+ (cannot-paste (or point-to-paste-read-only
+ (when (or wanna-cut-on-same-buffer
+ wanna-cut-on-other-buffer)
+ text-from-read-only))))
+
+ (cond
+ ;; Move point within region.
+ (clicked
+ (deactivate-mark)
+ (mouse-set-point event))
+ ;; Undo operation. Set back the original text as region.
+ ((or (and drag-but-negligible
+ no-modifier-on-drop)
+ cannot-paste)
+ ;; Inform user either source or destination buffer cannot be modified.
+ (when (and (not drag-but-negligible)
+ cannot-paste)
+ (message "Buffer is read-only"))
+
+ ;; Select source window back and restore region.
+ ;; (set-window-point window point)
+ (select-window window)
+ (goto-char point)
(setq deactivate-mark nil)
(activate-mark)
(when region-noncontiguous
(rectangle-mark-mode)))
-
- ;; * SOURCE BUFFER::
- ;; Set back the original text as region or delete the original
- ;; text, on source buffer.
- (if wanna-paste-to-same-buffer
- ;; When source buffer and destination buffer are the same,
- ;; remove the original text.
- (when no-modifier-on-drop
- (let (deactivate-mark)
+ ;; Modify buffers.
+ (t
+ ;; * DESTINATION BUFFER::
+ ;; Insert the text to destination buffer under mouse.
+ (select-window window-to-paste)
+ (setq window-exempt window-to-paste)
+ (goto-char point-to-paste)
+ (push-mark)
+ (insert-for-yank value-selection)
+
+ ;; On success, set the text as region on destination buffer.
+ (when (not (equal (mark) (point)))
+ (setq deactivate-mark nil)
+ (activate-mark)
+ (when region-noncontiguous
+ (rectangle-mark-mode)))
+
+ ;; * SOURCE BUFFER::
+ ;; Set back the original text as region or delete the original
+ ;; text, on source buffer.
+ (if wanna-paste-to-same-buffer
+ ;; When source buffer and destination buffer are the same,
+ ;; remove the original text.
+ (when no-modifier-on-drop
+ (let (deactivate-mark)
+ (dolist (overlay mouse-drag-and-drop-overlays)
+ (delete-region (overlay-start overlay)
+ (overlay-end overlay)))))
+ ;; When source buffer and destination buffer are different,
+ ;; keep (set back the original text as region) or remove the
+ ;; original text.
+ (select-window window) ; Select window with source buffer.
+ (goto-char point) ; Move point to the original text on source buffer.
+
+ (if mouse-drag-and-drop-region-cut-when-buffers-differ
+ ;; Remove the dragged text from source buffer like
+ ;; operation `cut'.
(dolist (overlay mouse-drag-and-drop-overlays)
(delete-region (overlay-start overlay)
- (overlay-end overlay)))))
- ;; When source buffer and destination buffer are different,
- ;; keep (set back the original text as region) or remove the
- ;; original text.
- (select-window window) ; Select window with source buffer.
- (goto-char point) ; Move point to the original text on source buffer.
-
- (if mouse-drag-and-drop-region-cut-when-buffers-differ
- ;; Remove the dragged text from source buffer like
- ;; operation `cut'.
- (dolist (overlay mouse-drag-and-drop-overlays)
- (delete-region (overlay-start overlay)
(overlay-end overlay)))
- ;; Set back the dragged text as region on source buffer
- ;; like operation `copy'.
- (activate-mark))
- (select-window window-to-paste))))))
+ ;; Set back the dragged text as region on source buffer
+ ;; like operation `copy'.
+ (activate-mark))
+ (select-window window-to-paste)))))))
;; Clean up.
(dolist (overlay mouse-drag-and-drop-overlays)
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 776f774172f..66898d77073 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -728,9 +728,18 @@ Use variable `browse-url-filename-alist' to map filenames to URLs."
browse-url-filename-alist))
(setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]"))
;; Encode all other file names properly.
- (setq file (mapconcat #'url-hexify-string
- (file-name-split file)
- "/")))
+ (let ((bits (file-name-split file)))
+ (setq file
+ (string-join
+ ;; On Windows, the first bit here might be "c:" or the
+ ;; like, so don't encode the ":" in the first bit.
+ (cons (let ((url-unreserved-chars
+ (if (file-name-absolute-p file)
+ (cons ?: url-unreserved-chars)
+ url-unreserved-chars)))
+ (url-hexify-string (car bits)))
+ (mapcar #'url-hexify-string (cdr bits)))
+ "/"))))
(dolist (map browse-url-filename-alist)
(when (and map (string-match (car map) file))
(setq file (replace-match (cdr map) t nil file))))
@@ -851,7 +860,11 @@ If ARGS are omitted, the default is to pass
((featurep 'pgtk)
(setq classname (pgtk-backend-display-class))
(if (equal classname "GdkWaylandDisplay")
- (setenv "WAYLAND_DISPLAY" dpy)
+ (progn
+ ;; The `display' frame parameter is probably wrong.
+ ;; See bug#53969 for some context.
+ ;; (setenv "WAYLAND_DISPLAY" dpy)
+ )
(setenv "DISPLAY" dpy)))
(t
(setenv "DISPLAY" dpy)))))
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 997b9e30fd4..d58fab896ed 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -191,25 +191,51 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and
:type 'boolean
:version "25.1")
-(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email)
- "A list specifying the format of the expansion of inline queries.
-This variable controls what `eudc-expand-inline' actually inserts in
-the buffer. First element is a string passed to `format'. Remaining
-elements are symbols indicating attribute names; the corresponding values
-are passed as additional arguments to `format'."
- :type '(list
- (string :tag "Format String")
- (repeat :inline t
- :tag "Attributes"
- (choice
- :tag "Attribute"
- (const :menu-tag "First Name" :tag "First Name" firstname)
- (const :menu-tag "Surname" :tag "Surname" name)
- (const :menu-tag "Email Address" :tag "Email Address" email)
- (const :menu-tag "Phone" :tag "Phone" phone)
- (symbol :menu-tag "Other")
- (symbol :tag "Attribute name"))))
- :version "25.1")
+(defcustom eudc-inline-expansion-format nil
+ "Specify the format of the expansion of inline queries.
+This variable controls what `eudc-expand-inline' actually inserts
+in the buffer. It is either a list, or a function.
+
+When set to a list, the expansion result will be formatted
+according to the first element of the list, a string, which is
+passed as the first argument to `format'. The remaining elements
+of the list are symbols indicating attribute names; the
+corresponding values are passed as additional arguments to
+`format'.
+
+When set to nil, the expansion result will be formatted using
+`eudc-rfc5322-make-address', and the PHRASE part will be
+formatted according to \"firstname name\", quoting the result if
+necessary. No COMMENT will be added in this case.
+
+When set to a function, the expansion result will be formatted
+using `eudc-rfc5322-make-address', and the referenced function is
+used to format the PHRASE, and COMMENT parts, respectively. It
+receives a single argument, which is an alist of
+protocol-specific attributes describing the recipient. To access
+the alist elements using generic EUDC attribute names, such as
+for example name, or email, use `eudc-translate-attribute-list'.
+The function should return a list, which should contain two
+elements. If the first element is a string, it will be used as
+the PHRASE part, quoting it if necessary. If the second element
+is a string, it will be used as the COMMENT part, unless it
+contains characters not allowed in the COMMENT part by RFC 5322,
+in which case the COMMENT part will be omitted."
+ :type '(choice (const :tag "RFC 5322 formatted \"first last <address>\"" nil)
+ (function :tag "RFC 5322 phrase/comment formatting function")
+ (list :tag "Format string (deprecated)"
+ (string :tag "Format String")
+ (repeat :inline t
+ :tag "Attributes"
+ (choice
+ :tag "Attribute"
+ (const :menu-tag "First Name" :tag "First Name" firstname)
+ (const :menu-tag "Surname" :tag "Surname" name)
+ (const :menu-tag "Email Address" :tag "Email Address" email)
+ (const :menu-tag "Phone" :tag "Phone" phone)
+ (symbol :menu-tag "Other")
+ (symbol :tag "Attribute name")))))
+ :version "29.1")
(defcustom eudc-inline-expansion-servers 'server-then-hotlist
"Which servers to contact for the expansion of inline queries.
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 7bbf54ee6cd..6ce89ce5be4 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -162,6 +162,75 @@ Value is the new string."
newtext)))
(concat rtn-str (substring str start))))
+
+(defconst eudc-rfc5322-atext-token "[:alpha:][:digit:]!#$%&'*+/=?^_`{|}~-"
+ "Printable US-ASCII characters not including specials. Used for atoms.")
+
+(defconst eudc-rfc5322-wsp-token " \t"
+ "Non-folding white space.")
+
+(defconst eudc-rfc5322-fwsp-token
+ (concat eudc-rfc5322-wsp-token "\n")
+ "Folding white space.")
+
+(defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027"
+ "Printable US-ASCII characters not including '(', ')', or '\\'.")
+
+(defun eudc-rfc5322-quote-phrase (string)
+ "Quote STRING if it needs quoting as a phrase in a header."
+ (if (string-match
+ (concat "[^" eudc-rfc5322-wsp-token eudc-rfc5322-atext-token "]")
+ string)
+ (concat "\"" string "\"")
+ string))
+
+(defun eudc-rfc5322-valid-comment-p (string)
+ "Check if STRING can be used as comment in a header."
+ (if (string-match
+ (concat "[^" eudc-rfc5322-cctext-token eudc-rfc5322-fwsp-token "]")
+ string)
+ nil
+ t))
+
+(defun eudc-rfc5322-make-address (address &optional firstname name comment)
+ "Create a valid address specification according to RFC5322.
+RFC5322 address specifications are used in message header fields
+to indicate senders and recipients of messages. They generally
+have one of the forms:
+
+ADDRESS
+ADDRESS (COMMENT)
+PHRASE <ADDRESS>
+PHRASE <ADDRESS> (COMMENT)
+
+The arguments FIRSTNAME and NAME are combined to form PHRASE.
+PHRASE is enclosed in double quotes if necessary.
+
+COMMENT is omitted if it contains any symbols outside the
+permitted set `eudc-rfc5322-cctext-token'."
+ (if (and address
+ (not (string-blank-p address)))
+ (let ((result address)
+ (name-given (and name
+ (not (string-blank-p name))))
+ (firstname-given (and firstname
+ (not (string-blank-p firstname))))
+ (valid-comment-given (and comment
+ (not (string-blank-p comment))
+ (eudc-rfc5322-valid-comment-p comment))))
+ (if (or name-given firstname-given)
+ (let ((phrase (string-trim (concat firstname " " name))))
+ (setq result
+ (concat
+ (eudc-rfc5322-quote-phrase phrase)
+ " <" result ">"))))
+ (if valid-comment-given
+ (setq result
+ (concat result " (" comment ")")))
+ result)
+ ;; nil or empty address, nothing to return
+ nil))
+
;;}}}
;;{{{ Server and Protocol Variable Routines
@@ -798,13 +867,62 @@ non-nil, collect results from all servers."
(error "There is more than one match for the query"))))))
;;;###autoload
+(defun eudc-format-inline-expansion-result (res query-attrs)
+ "Format a query result according to `eudc-inline-expansion-format'."
+ (cond
+ ;; format string
+ ((consp eudc-inline-expansion-format)
+ (string-trim (apply #'format
+ (car eudc-inline-expansion-format)
+ (mapcar
+ (lambda (field)
+ (or (cdr (assq field res))
+ ""))
+ (eudc-translate-attribute-list
+ (cdr eudc-inline-expansion-format))))))
+
+ ;; formatting function
+ ((functionp eudc-inline-expansion-format)
+ (let ((addr (cdr (assq (nth 2 query-attrs) res)))
+ (ucontent (funcall eudc-inline-expansion-format res)))
+ (if (and ucontent
+ (listp ucontent))
+ (let* ((phrase (car ucontent))
+ (comment (cadr ucontent))
+ (phrase-given
+ (and phrase
+ (stringp phrase)
+ (not (string-blank-p phrase))))
+ (valid-comment-given
+ (and comment
+ (stringp comment)
+ (not (string-blank-p comment))
+ (eudc-rfc5322-valid-comment-p
+ comment))))
+ (eudc-rfc5322-make-address
+ addr nil
+ (if phrase-given phrase nil)
+ (if valid-comment-given comment nil)))
+ (progn
+ (error "Error: the function referenced by \
+`eudc-inline-expansion-format' is expected to return a list.")
+ nil))))
+
+ ;; fallback behaviour (nil function, or non-matching type)
+ (t
+ (let ((fname (cdr (assq (nth 0 query-attrs) res)))
+ (lname (cdr (assq (nth 1 query-attrs) res)))
+ (addr (cdr (assq (nth 2 query-attrs) res))))
+ (eudc-rfc5322-make-address addr fname lname)))))
+
+;;;###autoload
(defun eudc-query-with-words (query-words &optional try-all-servers)
"Query the directory server, and return the matching responses.
The variable `eudc-inline-query-format' controls how to associate the
individual QUERY-WORDS with directory attribute names.
After querying the server for the given string, the expansion
specified by `eudc-inline-expansion-format' is applied to the
-matches before returning them.inserted in the buffer at point.
+matches before returning them.
Multiple servers can be tried with the same query until one finds a match,
see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil,
keep collecting results from subsequent servers after the first match."
@@ -848,28 +966,25 @@ keep collecting results from subsequent servers after the first match."
(unwind-protect
(cl-flet
((run-query
- (query-formats)
- (let ((response
- (eudc-query
- (eudc-format-query query-words (car query-formats))
- (eudc-translate-attribute-list
- (cdr eudc-inline-expansion-format)))))
- (when response
- ;; Process response through eudc-inline-expansion-format.
- (dolist (r response)
- (let ((response-string
- (apply #'format
- (car eudc-inline-expansion-format)
- (mapcar
- (lambda (field)
- (or (cdr (assq field r))
- ""))
- (eudc-translate-attribute-list
- (cdr eudc-inline-expansion-format))))))
- (if (> (length response-string) 0)
- (push response-string response-strings))))
- (when (not try-all-servers)
- (throw 'found nil))))))
+ (query-formats)
+ (let* ((query-attrs (eudc-translate-attribute-list
+ (if (consp eudc-inline-expansion-format)
+ (cdr eudc-inline-expansion-format)
+ '(firstname name email))))
+ (response
+ (eudc-query
+ (eudc-format-query query-words (car query-formats))
+ query-attrs)))
+ (when response
+ ;; Format response.
+ (dolist (r response)
+ (let ((response-string
+ (eudc-format-inline-expansion-result r query-attrs)))
+ (if response-string
+ (cl-pushnew response-string response-strings
+ :test #'equal))))
+ (when (not try-all-servers)
+ (throw 'found nil))))))
(catch 'found
;; Loop on the servers.
(dolist (server servers)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 700a6c3e82f..75dc679a3dd 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -2053,7 +2053,9 @@ If CHARSET is nil then use UTF-8."
(defun eww-write-bookmarks ()
(with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)
(insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n")
- (pp eww-bookmarks (current-buffer))))
+ (let ((print-length nil)
+ (print-level nil))
+ (pp eww-bookmarks (current-buffer)))))
(defun eww-read-bookmarks (&optional error-out)
"Read bookmarks from `eww-bookmarks'.
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 386f1d6095d..43d34a9d4d1 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -228,6 +228,10 @@ temporarily blinks with this face."
"Face for <h6> elements."
:version "28.1")
+(defface shr-code '((t :inherit fixed-pitch))
+ "Face used for rendering <code> blocks."
+ :version "29.1")
+
(defcustom shr-inhibit-images nil
"If non-nil, inhibit loading images."
:version "28.1"
@@ -1410,7 +1414,7 @@ ones, in case fg and bg are nil."
(shr-fontize-dom dom 'underline))
(defun shr-tag-code (dom)
- (let ((shr-current-font 'fixed-pitch))
+ (let ((shr-current-font 'shr-code))
(shr-generic dom)))
(defun shr-tag-tt (dom)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index ce90943d9a6..d897594f8d8 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -159,6 +159,7 @@ It is used for TCP/IP devices."
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . tramp-handle-list-system-processes)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -168,6 +169,7 @@ It is used for TCP/IP devices."
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . tramp-adb-handle-make-process)
(make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-attributes . tramp-handle-process-attributes)
(process-file . tramp-adb-handle-process-file)
(rename-file . tramp-adb-handle-rename-file)
(set-file-acl . ignore)
@@ -973,6 +975,7 @@ implementation will be used."
(tramp-make-tramp-temp-file v))))
(remote-tmpstderr
(and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
+ (orig-command command)
(program (car command))
(args (cdr command))
(command
@@ -1030,6 +1033,9 @@ implementation will be used."
(set-process-sentinel p sentinel))
(when filter
(set-process-filter p filter))
+ (process-put p 'remote-command orig-command)
+ (tramp-set-connection-property
+ p "remote-command" orig-command)
;; Set query flag and process marker for
;; this process. We ignore errors, because
;; the process could have finished already.
@@ -1364,10 +1370,29 @@ connection if a previous connection has died for some reason."
'tramp-adb-connection-local-default-shell-profile
tramp-adb-connection-local-default-shell-variables)
+(defconst tramp-adb-connection-local-default-ps-variables
+ '((tramp-process-attributes-ps-args)
+ (tramp-process-attributes-ps-format
+ . ((user . string)
+ (pid . number)
+ (ppid . number)
+ (vsize . number)
+ (rss . number)
+ (wchan . string) ; ??
+ (pc . string) ; ??
+ (state . string)
+ (args . nil))))
+ "Default connection-local ps variables for remote adb connections.")
+
+(connection-local-set-profile-variables
+ 'tramp-adb-connection-local-default-ps-profile
+ tramp-adb-connection-local-default-ps-variables)
+
(with-eval-after-load 'shell
(connection-local-set-profiles
`(:application tramp :protocol ,tramp-adb-method)
- 'tramp-adb-connection-local-default-shell-profile))
+ 'tramp-adb-connection-local-default-shell-profile
+ 'tramp-adb-connection-local-default-ps-profile))
;; `shell-mode' tries to open remote files like "/adb::~/.history".
;; This fails, because the tilde cannot be expanded. Tell
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 788e4573679..7f4eca3f7c7 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -267,6 +267,7 @@ It must be supported by libarchive(3).")
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-archive-handle-insert-directory)
(insert-file-contents . tramp-archive-handle-insert-file-contents)
+ (list-system-processes . ignore)
(load . tramp-archive-handle-load)
(lock-file . ignore)
(make-auto-save-file-name . ignore)
@@ -276,6 +277,7 @@ It must be supported by libarchive(3).")
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-archive-handle-not-implemented)
+ (process-attributes . ignore)
(process-file . ignore)
(rename-file . tramp-archive-handle-not-implemented)
(set-file-acl . ignore)
@@ -374,7 +376,9 @@ arguments to pass to the OPERATION."
;;;###autoload
(progn (defun tramp-register-archive-file-name-handler ()
"Add archive file name handler to `file-name-handler-alist'."
- (when tramp-archive-enabled
+ (when (and tramp-archive-enabled
+ (not
+ (rassq #'tramp-archive-file-name-handler file-name-handler-alist)))
(add-to-list 'file-name-handler-alist
(cons (tramp-archive-autoload-file-name-regexp)
#'tramp-archive-autoload-file-name-handler))
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
index fb3ba08bb14..ca7bcf35ce4 100644
--- a/lisp/net/tramp-crypt.el
+++ b/lisp/net/tramp-crypt.el
@@ -209,6 +209,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil."
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-crypt-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . ignore)
(load . tramp-handle-load)
(lock-file . tramp-crypt-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -218,6 +219,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil."
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-attributes . ignore)
(process-file . ignore)
(rename-file . tramp-crypt-handle-rename-file)
(set-file-acl . ignore)
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index d6120d2bee1..752dfdb068a 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -796,6 +796,7 @@ It has been changed in GVFS 1.14.")
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . ignore)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -805,6 +806,7 @@ It has been changed in GVFS 1.14.")
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-attributes . ignore)
(process-file . ignore)
(rename-file . tramp-gvfs-handle-rename-file)
(set-file-acl . ignore)
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
index 3b2e7c0f916..b7f82770c40 100644
--- a/lisp/net/tramp-integration.el
+++ b/lisp/net/tramp-integration.el
@@ -303,6 +303,220 @@ NAME must be equal to `tramp-current-connection'."
'(:application tramp)
'tramp-connection-local-default-shell-profile))
+;; Tested with FreeBSD 12.2.
+(defconst tramp-bsd-process-attributes-ps-args
+ `("-acxww"
+ "-o"
+ ,(mapconcat
+ #'identity
+ '("pid"
+ "euid"
+ "user"
+ "egid"
+ "egroup"
+ "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ",")
+ "-o"
+ ,(mapconcat
+ #'identity
+ '("state"
+ "ppid"
+ "pgid"
+ "sid"
+ "tty"
+ "tpgid"
+ "minflt"
+ "majflt"
+ "time"
+ "pri"
+ "nice"
+ "vsz"
+ "rss"
+ "etimes"
+ "pcpu"
+ "pmem"
+ "args")
+ ","))
+ "List of arguments for \"ps\".
+See `tramp-process-attributes-ps-args'.")
+
+(defconst tramp-bsd-process-attributes-ps-format
+ '((pid . number)
+ (euid . number)
+ (user . string)
+ (egid . number)
+ (group . string)
+ (comm . 52)
+ (state . string)
+ (ppid . number)
+ (pgrp . number)
+ (sess . number)
+ (ttname . string)
+ (tpgid . number)
+ (minflt . number)
+ (majflt . number)
+ (time . tramp-ps-time)
+ (pri . number)
+ (nice . number)
+ (vsize . number)
+ (rss . number)
+ (etime . number)
+ (pcpu . number)
+ (pmem . number)
+ (args . nil))
+ "Alist of formats for \"ps\".
+See `tramp-process-attributes-ps-format'.")
+
+(defconst tramp-connection-local-bsd-ps-variables
+ `((tramp-process-attributes-ps-args
+ . ,tramp-bsd-process-attributes-ps-args)
+ (tramp-process-attributes-ps-format
+ . ,tramp-bsd-process-attributes-ps-format))
+ "Default connection-local ps variables for remote BSD connections.")
+
+(connection-local-set-profile-variables
+ 'tramp-connection-local-bsd-ps-profile
+ tramp-connection-local-bsd-ps-variables)
+
+;; Tested with BusyBox v1.24.1.
+(defconst tramp-busybox-process-attributes-ps-args
+ `("-o"
+ ,(mapconcat
+ #'identity
+ '("pid"
+ "user"
+ "group"
+ "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ",")
+ "-o" "stat=abcde"
+ "-o"
+ ,(mapconcat
+ #'identity
+ '("ppid"
+ "pgid"
+ "tty"
+ "time"
+ "nice"
+ "etime"
+ "args")
+ ","))
+ "List of arguments for \"ps\".
+See `tramp-process-attributes-ps-args'.")
+
+(defconst tramp-busybox-process-attributes-ps-format
+ '((pid . number)
+ (user . string)
+ (group . string)
+ (comm . 52)
+ (state . 5)
+ (ppid . number)
+ (pgrp . number)
+ (ttname . string)
+ (time . tramp-ps-time)
+ (nice . number)
+ (etime . tramp-ps-time)
+ (args . nil))
+ "Alist of formats for \"ps\".
+See `tramp-process-attributes-ps-format'.")
+
+(defconst tramp-connection-local-busybox-ps-variables
+ `((tramp-process-attributes-ps-args
+ . ,tramp-busybox-process-attributes-ps-args)
+ (tramp-process-attributes-ps-format
+ . ,tramp-busybox-process-attributes-ps-format))
+ "Default connection-local ps variables for remote Busybox connections.")
+
+(connection-local-set-profile-variables
+ 'tramp-connection-local-busybox-ps-profile
+ tramp-connection-local-busybox-ps-variables)
+
+;; Darwin (macOS).
+(defconst tramp-darwin-process-attributes-ps-args
+ `("-acxww"
+ "-o"
+ ,(mapconcat
+ #'identity
+ '("pid"
+ "uid"
+ "user"
+ "gid"
+ "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ",")
+ "-o" "state=abcde"
+ "-o"
+ ,(mapconcat
+ #'identity
+ '("ppid"
+ "pgid"
+ "sess"
+ "tty"
+ "tpgid"
+ "minflt"
+ "majflt"
+ "time"
+ "pri"
+ "nice"
+ "vsz"
+ "rss"
+ "etime"
+ "pcpu"
+ "pmem"
+ "args")
+ ","))
+ "List of arguments for \"ps\".
+See `tramp-process-attributes-ps-args'.")
+
+(defconst tramp-darwin-process-attributes-ps-format
+ '((pid . number)
+ (euid . number)
+ (user . string)
+ (egid . number)
+ (comm . 52)
+ (state . 5)
+ (ppid . number)
+ (pgrp . number)
+ (sess . number)
+ (ttname . string)
+ (tpgid . number)
+ (minflt . number)
+ (majflt . number)
+ (time . tramp-ps-time)
+ (pri . number)
+ (nice . number)
+ (vsize . number)
+ (rss . number)
+ (etime . tramp-ps-time)
+ (pcpu . number)
+ (pmem . number)
+ (args . nil))
+ "Alist of formats for \"ps\".
+See `tramp-process-attributes-ps-format'.")
+
+(defconst tramp-connection-local-darwin-ps-variables
+ `((tramp-process-attributes-ps-args
+ . ,tramp-darwin-process-attributes-ps-args)
+ (tramp-process-attributes-ps-format
+ . ,tramp-darwin-process-attributes-ps-format))
+ "Default connection-local ps variables for remote Darwin connections.")
+
+(connection-local-set-profile-variables
+ 'tramp-connection-local-darwin-ps-profile
+ tramp-connection-local-darwin-ps-variables)
+
+;; Preset default "ps" profile for local hosts, based on system type.
+
+(when-let ((local-profile
+ (cond ((eq system-type 'darwin)
+ 'tramp-connection-local-darwin-ps-profile)
+ ;; ... Add other system types here.
+ )))
+ (connection-local-set-profiles
+ `(:application tramp :machine ,(system-name))
+ local-profile)
+ (connection-local-set-profiles
+ '(:application tramp :machine "localhost")
+ local-profile))
+
(add-hook 'tramp-unload-hook
(lambda () (unload-feature 'tramp-integration 'force)))
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 126b09fcbf3..bbc76851318 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -123,6 +123,7 @@
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . ignore)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -132,6 +133,7 @@
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-attributes . ignore)
(process-file . ignore)
(rename-file . tramp-rclone-handle-rename-file)
(set-file-acl . ignore)
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 475d48cc30b..a8f265223f9 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1005,6 +1005,7 @@ Format specifiers \"%s\" are replaced before the script is used.")
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-sh-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . tramp-handle-list-system-processes)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -1014,6 +1015,7 @@ Format specifiers \"%s\" are replaced before the script is used.")
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . tramp-sh-handle-make-process)
(make-symbolic-link . tramp-sh-handle-make-symbolic-link)
+ (process-attributes . tramp-handle-process-attributes)
(process-file . tramp-sh-handle-process-file)
(rename-file . tramp-sh-handle-rename-file)
(set-file-acl . tramp-sh-handle-set-file-acl)
@@ -2715,7 +2717,9 @@ The method used must be an out-of-band method."
;; Try to insert the amount of free space.
(goto-char (point-min))
;; First find the line to put it on.
- (when (re-search-forward "^\\([[:space:]]*total\\)" nil t)
+ (when (and (re-search-forward "^\\([[:space:]]*total\\)" nil t)
+ ;; Emacs 29.1 or later.
+ (not (fboundp 'dired--insert-disk-space)))
(when-let ((available (get-free-disk-space ".")))
;; Replace "total" with "total used", to avoid confusion.
(replace-match "\\1 used in directory")
@@ -2854,6 +2858,7 @@ implementation will be used."
stderr (tramp-make-tramp-temp-name v)))))
(remote-tmpstderr
(and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
+ (orig-command command)
(program (car command))
(args (cdr command))
;; When PROGRAM matches "*sh", and the first arg is
@@ -2865,8 +2870,10 @@ implementation will be used."
(string-match-p "sh$" program)
(= (length args) 2)
(string-equal "-c" (car args))
- ;; Don't if there is a string.
- (not (string-match-p "'\\|\"" (cadr args)))))
+ ;; Don't if there is a quoted string.
+ (not (string-match-p "'\\|\"" (cadr args)))
+ ;; Check, that /dev/tty is usable.
+ (tramp-get-remote-dev-tty v)))
;; When PROGRAM is nil, we just provide a tty.
(args (if (not heredoc) args
(let ((i 250))
@@ -3008,6 +3015,9 @@ implementation will be used."
(set-process-sentinel p sentinel))
(when filter
(set-process-filter p filter))
+ (process-put p 'remote-command orig-command)
+ (tramp-set-connection-property
+ p "remote-command" orig-command)
;; Set query flag and process marker for this
;; process. We ignore errors, because the
;; process could have finished already.
@@ -4873,7 +4883,8 @@ Goes through the list `tramp-inline-compress-commands'."
"\\(illegal\\|unknown\\) option -- R" nil 'noerror)))))
;; Check, that RemoteCommand is not used.
- (with-tramp-connection-property (tramp-get-process vec1) "remote-command"
+ (with-tramp-connection-property
+ (tramp-get-process vec1) "ssh-remote-command"
(let ((command `("ssh" "-G" ,(tramp-file-name-host vec1))))
(with-temp-buffer
(tramp-call-process
@@ -4953,6 +4964,7 @@ connection if a previous connection has died for some reason."
;; If Tramp opens the same connection within a short time frame,
;; there is a problem. We shall signal this.
(unless (or (process-live-p p)
+ (and (processp p) (not non-essential))
(not (tramp-file-name-equal-p
vec (car tramp-current-connection)))
(time-less-p
@@ -5933,6 +5945,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
command))
(delete-file tmpfile)))))
+(defun tramp-get-remote-dev-tty (vec)
+ "Check, whether remote /dev/tty is usable."
+ (with-tramp-connection-property vec "dev-tty"
+ (tramp-send-command-and-check
+ vec "echo </dev/tty")))
+
;; Some predefined connection properties.
(defun tramp-get-inline-compress (vec prop size)
"Return the compress command related to PROP.
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 67c63e6ce7a..4af5a4204f2 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -274,6 +274,7 @@ See `tramp-actions-before-shell' for more info.")
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-smb-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . ignore)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -283,6 +284,7 @@ See `tramp-actions-before-shell' for more info.")
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-smb-handle-make-symbolic-link)
+ (process-attributes . ignore)
(process-file . tramp-smb-handle-process-file)
(rename-file . tramp-smb-handle-rename-file)
(set-file-acl . tramp-smb-handle-set-file-acl)
@@ -1129,7 +1131,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Insert size information.
(when full-directory-p
(insert
- (if avail
+ (if (and avail
+ ;; Emacs 29.1 or later.
+ (not (fboundp 'dired--insert-disk-space)))
(format "total used in directory %s available %s\n" used avail)
(format "total %s\n" used))))
@@ -1542,7 +1546,8 @@ component is used as the target of the symlink."
(command (string-join (cons program args) " "))
(bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
(name1 name)
- (i 0))
+ (i 0)
+ p)
(unwind-protect
(save-excursion
(save-restriction
@@ -1565,8 +1570,13 @@ component is used as the target of the symlink."
host (file-name-directory localname))))
(tramp-message v 6 "(%s); exit" command)
(tramp-send-string v command)))
+ (setq p (tramp-get-connection-process v))
+ (when program
+ (process-put p 'remote-command (cons program args))
+ (tramp-set-connection-property
+ p "remote-command" (cons program args)))
;; Return value.
- (tramp-get-connection-process v)))
+ p))
;; Save exit.
(with-current-buffer (tramp-get-connection-buffer v)
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 9dcb6259fb1..02c0da3f184 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -126,6 +126,7 @@
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-sshfs-handle-insert-file-contents)
+ (list-system-processes . tramp-handle-list-system-processes)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -135,6 +136,7 @@
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . tramp-handle-make-process)
(make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-attributes . tramp-handle-process-attributes)
(process-file . tramp-sshfs-handle-process-file)
(rename-file . tramp-sshfs-handle-rename-file)
(set-file-acl . ignore)
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index 242a6c7f587..fb885ebd054 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -117,6 +117,7 @@ See `tramp-actions-before-shell' for more info.")
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
+ (list-system-processes . ignore)
(load . tramp-handle-load)
(lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
@@ -126,6 +127,7 @@ See `tramp-actions-before-shell' for more info.")
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link)
+ (process-attributes . ignore)
(process-file . ignore)
(rename-file . tramp-sudoedit-handle-rename-file)
(set-file-acl . tramp-sudoedit-handle-set-file-acl)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 38bdfab1929..1f429edf4f8 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2599,7 +2599,9 @@ Must be handled by the callers."
'(make-nearby-temp-file process-file shell-command
start-file-process temporary-file-directory
;; Emacs 27+ only.
- exec-path make-process))
+ exec-path make-process
+ ;; Emacs 29+ only.
+ list-system-processes process-attributes))
default-directory)
;; PROC.
((member operation '(file-notify-rm-watch file-notify-valid-p))
@@ -2756,10 +2758,11 @@ Falls back to normal file name handler if no Tramp file name handler exists."
;;;###autoload
(progn (defun tramp-register-autoload-file-name-handlers ()
"Add Tramp file name handlers to `file-name-handler-alist' during autoload."
- (add-to-list 'file-name-handler-alist
- (cons tramp-autoload-file-name-regexp
- #'tramp-autoload-file-name-handler))
- (put #'tramp-autoload-file-name-handler 'safe-magic t)))
+ (unless (rassq #'tramp-file-name-handler file-name-handler-alist)
+ (add-to-list 'file-name-handler-alist
+ (cons tramp-autoload-file-name-regexp
+ #'tramp-autoload-file-name-handler))
+ (put #'tramp-autoload-file-name-handler 'safe-magic t))))
(put #'tramp-register-autoload-file-name-handlers 'tramp-autoload t)
;;;###autoload (tramp-register-autoload-file-name-handlers)
@@ -4000,6 +4003,155 @@ Let-bind it when necessary.")
;; Result.
(cons filename (cdr result)))))
+(defun tramp-ps-time ()
+ "Read printed time oif \"ps\" in format \"[[DD-]hh:]mm:ss\".
+Return it as number of seconds. Used in `tramp-process-attributes-ps-format'."
+ (search-forward-regexp "\\s-+")
+ (search-forward-regexp
+ (concat
+ "\\(?:" "\\(?:" "\\([0-9]+\\)-" "\\)?"
+ "\\([0-9]+\\):" "\\)?"
+ "\\([0-9]+\\):"
+ ;; Seconds can also be a floating point number.
+ "\\([0-9.]+\\)")
+ (line-end-position) 'noerror)
+ (+ (* 24 60 60 (string-to-number (or (match-string 1) "0")))
+ (* 60 60 (string-to-number (or (match-string 2) "0")))
+ (* 60 (string-to-number (or (match-string 3) "0")))
+ (string-to-number (or (match-string 4) "0"))))
+
+(defconst tramp-process-attributes-ps-args
+ `("-eww"
+ "-o"
+ ,(mapconcat
+ #'identity
+ '("pid"
+ "euid"
+ "euser"
+ "egid"
+ "egroup"
+ "comm:80"
+ "state"
+ "ppid"
+ "pgrp"
+ "sess"
+ "tname"
+ "tpgid"
+ "min_flt"
+ "maj_flt"
+ "times"
+ "pri"
+ "nice"
+ "thcount"
+ "vsize"
+ "rss"
+ "etimes"
+ "pcpu"
+ "pmem"
+ "args")
+ ","))
+ "List of arguments for calling \"ps\".
+See `tramp-get-process-attributes'.
+
+This list is the default value on remote GNU/Linux systems.")
+
+(defconst tramp-process-attributes-ps-format
+ '((pid . number)
+ (euid . number)
+ (user . string)
+ (egid . number)
+ (group . string)
+ (comm . 80)
+ (state . string)
+ (ppid . number)
+ (pgrp . number)
+ (sess . number)
+ (ttname . string)
+ (tpgid . number)
+ (minflt . number)
+ (majflt . number)
+ (time . number)
+ (pri . number)
+ (nice . number)
+ (thcount . number)
+ (vsize . number)
+ (rss . number)
+ (etime . number)
+ (pcpu . number)
+ (pmem . number)
+ (args . nil))
+ "Alist where each element is a cons cell of the form `\(KEY . TYPE)'.
+KEY is a key (symbol) used in `process-attributes'. TYPE is the
+printed result for KEY of the \"ps\" command, it can be `number',
+`string', a number (string of that length), a symbol (a function
+to be applied), or nil (for the last column of the \"ps\" output.
+
+This alist is used to parse the output of calling \"ps\" in
+`tramp-get-process-attributes'.
+
+This alist is the default value on remote GNU/Linux systems.")
+
+(defun tramp-get-process-attributes (vec)
+ "Return all process attributes for connection VEC.
+Parsing the remote \"ps\" output is controlled by
+`tramp-process-attributes-ps-args' and
+`tramp-process-attributes-ps-format'.
+
+It is not guaranteed, that all process attributes as described in
+`process-attributes' are returned. The additional attribute
+`pid' shall be returned always."
+ (with-tramp-file-property vec "/" "process-attributes"
+ (ignore-errors
+ (with-temp-buffer
+ (hack-connection-local-variables-apply
+ (connection-local-criteria-for-default-directory))
+ ;; (pop-to-buffer (current-buffer))
+ (when (zerop
+ (apply
+ #'process-file
+ "ps" nil t nil tramp-process-attributes-ps-args))
+ (let (result res)
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; (tramp-test-message
+ ;; "%s" (buffer-substring (point) (line-end-position)))
+ (when (save-excursion
+ (search-forward-regexp
+ "[[:digit:]]" (line-end-position) 'noerror))
+ (setq res nil)
+ (dolist (elt tramp-process-attributes-ps-format)
+ (push
+ (cons
+ (car elt)
+ (cond
+ ((eq (cdr elt) 'number) (read (current-buffer)))
+ ((eq (cdr elt) 'string)
+ (search-forward-regexp "\\S-+")
+ (match-string 0))
+ ((numberp (cdr elt))
+ (search-forward-regexp "\\s-+")
+ (search-forward-regexp ".+" (+ (point) (cdr elt)))
+ (string-trim (match-string 0)))
+ ((fboundp (cdr elt))
+ (funcall (cdr elt)))
+ ((null (cdr elt))
+ (search-forward-regexp "\\s-+")
+ (buffer-substring (point) (line-end-position)))
+ (t nil)))
+ res))
+ ;; `nice' could be `-'.
+ (setq res (rassq-delete-all '- res))
+ (push (append res) result))
+ (forward-line))
+ ;; Return result.
+ result))))))
+
+(defun tramp-handle-list-system-processes ()
+ "Like `list-system-processes' for Tramp files."
+ (let ((v (tramp-dissect-file-name default-directory)))
+ (tramp-flush-file-property v "/" "process-attributes")
+ (mapcar (lambda (x) (cdr (assq 'pid x))) (tramp-get-process-attributes v))))
+
(defun tramp-get-lock-file (file)
"Read lockfile info of FILE.
Return nil when there is no lockfile."
@@ -4315,6 +4467,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for
(get-buffer-create buffer)
;; BUFFER can be nil. We use a temporary buffer.
(generate-new-buffer tramp-temp-buffer-name)))
+ (orig-command command)
(env (mapcar
(lambda (elt)
(when (tramp-compat-string-search "=" elt) elt))
@@ -4390,6 +4543,8 @@ substitution. SPEC-LIST is a list of char/value pairs used for
;; t. See Bug#51177.
(when filter
(set-process-filter p filter))
+ (process-put p 'remote-command orig-command)
+ (tramp-set-connection-property p "remote-command" orig-command)
(tramp-message v 6 "%s" (string-join (process-command p) " "))
p))))))
@@ -4403,6 +4558,14 @@ support symbolic links."
(tramp-dissect-file-name (expand-file-name linkname)) 'file-error
"make-symbolic-link not supported"))
+(defun tramp-handle-process-attributes (pid)
+ "Like `process-attributes' for Tramp files."
+ (catch 'result
+ (dolist (elt (tramp-get-process-attributes
+ (tramp-dissect-file-name default-directory)))
+ (when (= (cdr (assq 'pid elt)) pid)
+ (throw 'result elt)))))
+
(defun tramp-handle-shell-command (command &optional output-buffer error-buffer)
"Like `shell-command' for Tramp files."
(let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command))
@@ -5008,8 +5171,9 @@ performed successfully. Any other value means an error."
(tramp-message vec 6 "\n%s" (buffer-string)))
(if (eq exit 'ok)
(ignore-errors
- (and (functionp tramp-password-save-function)
- (funcall tramp-password-save-function)))
+ (when (functionp tramp-password-save-function)
+ (funcall tramp-password-save-function)
+ (setq tramp-password-save-function nil)))
;; Not successful.
(tramp-clear-passwd vec)
(delete-process proc)
@@ -5956,6 +6120,45 @@ name of a process or buffer, or nil to default to the current buffer."
(lambda ()
(remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))
+(defun tramp-signal-process (process sigcode &optional remote)
+ "Send PROCESS the signal with code SIGCODE.
+PROCESS may also be a number specifying the process id of the
+process to signal; in this case, the process need not be a child of
+this Emacs.
+If PROCESS is a process object which contains the property
+`remote-pid', or PROCESS is a number and REMOTE is a remote file name,
+PROCESS is interpreted as process on the respective remote host, which
+will be the process to signal.
+SIGCODE may be an integer, or a symbol whose name is a signal name."
+ (let (pid vec)
+ (cond
+ ((processp process)
+ (setq pid (process-get process 'remote-pid)
+ vec (process-get process 'vector)))
+ ((numberp process)
+ (setq pid process
+ vec (and (stringp remote) (tramp-dissect-file-name remote))))
+ (t (signal 'wrong-type-argument (list #'processp process))))
+ (unless (or (numberp sigcode) (symbolp sigcode))
+ (signal 'wrong-type-argument (list #'numberp sigcode)))
+ ;; If it's a Tramp process, send SIGCODE remotely.
+ (when (and pid vec)
+ (tramp-message
+ vec 5 "Send signal %s to process %s with pid %s" sigcode process pid)
+ ;; This is for tramp-sh.el. Other backends do not support this (yet).
+ (if (tramp-compat-funcall
+ 'tramp-send-command-and-check
+ vec (format "\\kill -%s %d" sigcode pid))
+ 0 -1))))
+
+;; `signal-process-functions' exists since Emacs 29.1.
+(when (boundp 'signal-process-functions)
+ (add-hook 'signal-process-functions #'tramp-signal-process)
+ (add-hook
+ 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'signal-process-functions #'tramp-signal-process))))
+
(defun tramp-get-remote-null-device (vec)
"Return null device on the remote host identified by VEC.
If VEC is `tramp-null-hop', return local null device."
diff --git a/lisp/org/ol.el b/lisp/org/ol.el
index 905e491f4ad..a03d85f618a 100644
--- a/lisp/org/ol.el
+++ b/lisp/org/ol.el
@@ -1575,7 +1575,7 @@ non-nil."
(setq link
(format-time-string
(car org-time-stamp-formats)
- (encode-time
+ (apply 'encode-time
(list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd)
nil nil nil))))
(org-link-store-props :type "calendar" :date cd)))
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index dce5d9d4c0c..73956691096 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -1904,11 +1904,11 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
((match-end 2)
;; Two time stamps.
(let* ((ts (float-time
- (encode-time
+ (apply #'encode-time
(save-match-data
(org-parse-time-string (match-string 2))))))
(te (float-time
- (encode-time
+ (apply #'encode-time
(org-parse-time-string (match-string 3)))))
(dt (- (if tend (min te tend) te)
(if tstart (max ts tstart) ts))))
@@ -3042,9 +3042,9 @@ Otherwise, return nil."
(setq ts (match-string 1)
te (match-string 3))
(setq s (- (float-time
- (encode-time (org-parse-time-string te)))
+ (apply #'encode-time (org-parse-time-string te)))
(float-time
- (encode-time (org-parse-time-string ts))))
+ (apply #'encode-time (org-parse-time-string ts))))
neg (< s 0)
s (abs s)
h (floor (/ s 3600))
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index 371889432d3..829fcbbe3fb 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -782,7 +782,7 @@ around it."
(setq time-after (copy-sequence time))
(setf (nth 3 time-before) (1- (nth 3 time)))
(setf (nth 3 time-after) (1+ (nth 3 time)))
- (mapcar (lambda (x) (format-time-string fmt (encode-time x)))
+ (mapcar (lambda (x) (format-time-string fmt (apply #'encode-time x)))
(list time-before time time-after)))))
(defun org-columns-open-link (&optional arg)
diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el
index bb8a95065b3..0921f3aa27c 100644
--- a/lisp/org/org-macro.el
+++ b/lisp/org/org-macro.el
@@ -378,7 +378,7 @@ Return value as a string."
(buffer-substring
(point) (line-end-position)))))
(when (cl-some #'identity time)
- (setq date (encode-time time))))))))
+ (setq date (apply #'encode-time time))))))))
(let ((proc (get-buffer-process buf)))
(while (and proc (accept-process-output proc .5 nil t)))))
(kill-buffer buf))
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 6f038f026bf..b10725bd526 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -1185,7 +1185,7 @@ nil, just return 0."
((numberp s) s)
((stringp s)
(condition-case nil
- (float-time (encode-time (org-parse-time-string s)))
+ (float-time (apply #'encode-time (org-parse-time-string s)))
(error 0)))
(t 0)))
@@ -1252,7 +1252,7 @@ following special strings: \"<now>\", \"<today>\",
\"<tomorrow>\", and \"<yesterday>\".
Return 0. if S is not recognized as a valid value."
- (let ((today (float-time (encode-time
+ (let ((today (float-time (apply #'encode-time
(append '(0 0 0) (nthcdr 3 (decode-time)))))))
(save-match-data
(cond
diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el
index 8d5be425453..20c20acc320 100644
--- a/lisp/org/org-mouse.el
+++ b/lisp/org/org-mouse.el
@@ -295,7 +295,7 @@ nor a function, elements of KEYWORDS are used directly."
((functionp itemformat) (funcall itemformat keyword))
((stringp itemformat) (format itemformat keyword))
(t keyword))
- (list 'funcall function keyword)
+ `(funcall #',function ,keyword)
:style (cond
((null selected) t)
((functionp selected) 'toggle)
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index 58707eae440..c4daed16656 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -2606,7 +2606,7 @@ location of point."
(format-time-string
(org-time-stamp-format
(string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts))
- (encode-time
+ (apply #'encode-time
(save-match-data (org-parse-time-string ts))))))
form t t))
diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el
index a38b79304ef..e82dbbf398c 100644
--- a/lisp/org/org-version.el
+++ b/lisp/org/org-version.el
@@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made."
(defun org-git-version ()
"The Git version of Org mode.
Inserted by installing Org or when a release is made."
- (let ((org-git-version "release_9.5.2-24-g668205"))
+ (let ((org-git-version "release_9.5.2-25-gaf6f12"))
org-git-version))
(provide 'org-version)
diff --git a/lisp/org/org.el b/lisp/org/org.el
index 67c8f1cedf7..d656a51591e 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -13986,7 +13986,7 @@ user."
(when (< (nth 2 org-defdecode) org-extend-today-until)
(setf (nth 2 org-defdecode) -1)
(setf (nth 1 org-defdecode) 59)
- (setq org-def (encode-time org-defdecode))
+ (setq org-def (apply #'encode-time org-defdecode))
(setq org-defdecode (decode-time org-def)))
(let* ((timestr (format-time-string
(if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d")
@@ -14470,7 +14470,7 @@ The command returns the inserted time stamp."
time (org-fix-decoded-time t1)
str (org-add-props
(format-time-string
- (substring tf 1 -1) (encode-time time))
+ (substring tf 1 -1) (apply 'encode-time time))
nil 'mouse-face 'highlight))
(put-text-property beg end 'display str)))
@@ -14725,7 +14725,7 @@ days in order to avoid rounding problems."
(defun org-time-string-to-time (s)
"Convert timestamp string S into internal time."
- (encode-time (org-parse-time-string s)))
+ (apply #'encode-time (org-parse-time-string s)))
(defun org-time-string-to-seconds (s)
"Convert a timestamp string S into a number of seconds."
@@ -15155,7 +15155,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like
(setcar time0 (or (car time0) 0))
(setcar (nthcdr 1 time0) (or (nth 1 time0) 0))
(setcar (nthcdr 2 time0) (or (nth 2 time0) 0))
- (setq time (encode-time time0))))
+ (setq time (apply 'encode-time time0))))
;; Insert the new time-stamp, and ensure point stays in the same
;; category as before (i.e. not after the last position in that
;; category).
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 289312e0bbc..a1492af89d2 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -189,6 +189,16 @@ and how is entirely up to the behavior of the
`pcomplete-parse-arguments-function'."
:type 'boolean)
+(defvar pcomplete-allow-modifications nil
+ "If non-nil, allow effects in `pcomplete-parse-arguments-function'.
+For the `pcomplete' command, it was common for functions in
+`pcomplete-parse-arguments-function' to make modifications to the
+buffer, like expanding variables are such.
+For `completion-at-point-functions', this is not an option any more, so
+this variable is used to tell `pcomplete-parse-arguments-function'
+whether it can do the modifications like it used to, or whether
+it should refrain from doing so.")
+
(defcustom pcomplete-parse-arguments-function
#'pcomplete-parse-buffer-arguments
"A function to call to parse the current line's arguments.
@@ -392,6 +402,9 @@ Same as `pcomplete' but using the standard completion UI."
;; imposing the pcomplete UI over the standard UI.
(catch 'pcompleted
(let* ((pcomplete-stub)
+ (buffer-read-only
+ ;; Make sure the function obeys `pcomplete-allow-modifications'.
+ (if pcomplete-allow-modifications buffer-read-only t))
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
(pcomplete-autolist pcomplete-autolist)
@@ -526,6 +539,7 @@ completion functions list (it should occur fairly early in the list)."
pcomplete-last-completion-raw nil)
(catch 'pcompleted
(let* ((pcomplete-stub)
+ (pcomplete-allow-modifications t)
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
(pcomplete-autolist pcomplete-autolist)
@@ -551,7 +565,8 @@ completion functions list (it should occur fairly early in the list)."
"Expand the textual value of the current argument.
This will modify the current buffer."
(interactive)
- (let ((pcomplete-expand-before-complete t))
+ (let ((pcomplete-expand-before-complete t)
+ (pcomplete-allow-modifications t))
(with-suppressed-warnings ((obsolete pcomplete))
(pcomplete))))
@@ -569,6 +584,7 @@ This will modify the current buffer."
This will modify the current buffer."
(interactive)
(let ((pcomplete-expand-before-complete t)
+ (pcomplete-allow-modifications t)
(pcomplete-expand-only-p t))
(with-suppressed-warnings ((obsolete pcomplete))
(pcomplete))
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index bfe48ef1f90..b0fe2f56c03 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -90,6 +90,7 @@
(require 'mwheel)
(require 'subr-x)
(require 'ring)
+(require 'cua-base)
(defvar pixel-wait 0
"Idle time on each step of pixel scroll specified in second.
@@ -213,6 +214,14 @@ This is only effective when `pixel-scroll-precision-mode' is enabled."
:type 'boolean
:version "29.1")
+(defcustom pixel-scroll-precision-interpolate-mice t
+ "Whether or not to interpolate scrolling from a mouse.
+If non-nil, scrolling from the mouse wheel of an actual mouse (as
+opposed to a touchpad) will cause Emacs to interpolate the scroll."
+ :group 'scrolling
+ :type 'boolean
+ :version "29.1")
+
(defun pixel-scroll-in-rush-p ()
"Return non-nil if next scroll should be non-smooth.
When scrolling request is delivered soon after the previous one,
@@ -680,16 +689,20 @@ wheel."
(if (> (abs delta) (window-text-height window t))
(mwheel-scroll event nil)
(with-selected-window window
- (if (and pixel-scroll-precision-large-scroll-height
- (> (abs delta)
- pixel-scroll-precision-large-scroll-height)
- (let* ((kin-state (pixel-scroll-kinetic-state))
- (ring (aref kin-state 0))
- (time (aref kin-state 1)))
- (or (null time)
- (> (- (float-time) time) 1.0)
- (and (consp ring)
- (ring-empty-p ring)))))
+ (if (or (and pixel-scroll-precision-interpolate-mice
+ (eq (device-class last-event-frame
+ last-event-device)
+ 'mouse))
+ (and pixel-scroll-precision-large-scroll-height
+ (> (abs delta)
+ pixel-scroll-precision-large-scroll-height)
+ (let* ((kin-state (pixel-scroll-kinetic-state))
+ (ring (aref kin-state 0))
+ (time (aref kin-state 1)))
+ (or (null time)
+ (> (- (float-time) time) 1.0)
+ (and (consp ring)
+ (ring-empty-p ring))))))
(progn
(let ((kin-state (pixel-scroll-kinetic-state)))
(aset kin-state 0 (make-ring 30))
@@ -803,14 +816,14 @@ It is a vector of the form [ VELOCITY TIME SIGN ]."
(interactive)
(if pixel-scroll-precision-interpolate-page
(pixel-scroll-precision-interpolate (- (window-text-height nil t)))
- (scroll-up)))
+ (cua-scroll-up)))
(defun pixel-scroll-interpolate-up ()
"Interpolate a scroll upwards by one page."
(interactive)
(if pixel-scroll-precision-interpolate-page
(pixel-scroll-precision-interpolate (window-text-height nil t))
- (scroll-down)))
+ (cua-scroll-down)))
;;;###autoload
(define-minor-mode pixel-scroll-precision-mode
diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el
index 7f821bf4cf4..bb3369de5fc 100644
--- a/lisp/play/decipher.el
+++ b/lisp/play/decipher.el
@@ -978,13 +978,14 @@ if it can't, it signals an error."
decipher-stats-buffer)
;; Create a new buffer if requested:
(create
- (let ((stats-name (concat "*" (buffer-name) "*")))
+ (let* ((stats-name (concat "*" (buffer-name) "*"))
+ (buf (get-buffer stats-name)))
(setq decipher-stats-buffer
- (if (eq 'decipher-stats-mode
- (buffer-local-value 'major-mode
- (get-buffer stats-name)))
- ;; We just lost track of the statistics buffer:
- (get-buffer stats-name)
+ (if (and (bufferp buf)
+ (eq 'decipher-stats-mode
+ (buffer-local-value 'major-mode buf)))
+ buf
+ ;; We just lost track of the statistics buffer:
(generate-new-buffer stats-name))))
(with-current-buffer decipher-stats-buffer
(decipher-stats-mode))
diff --git a/lisp/proced.el b/lisp/proced.el
index c1d599afc4a..a27638d3679 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -29,10 +29,6 @@
;;
;; To do:
;; - Interactive temporary customizability of flags in `proced-grammar-alist'
-;; - Allow "sudo kill PID", "sudo renice PID"
-;; `proced-send-signal' operates on multiple processes one by one.
-;; With "sudo" we want to execute one "kill" or "renice" command
-;; for all marked processes. Is there a `sudo-call-process'?
;;
;; Thoughts and Ideas
;; - Currently, `process-attributes' returns the list of
@@ -55,12 +51,19 @@
:group 'unix
:prefix "proced-")
+(defcustom proced-show-remote-processes nil
+ "Whether processes of the remote host shall be shown.
+This happens only when `default-directory' is remote."
+ :version "29.1"
+ :type 'boolean)
+
(defcustom proced-signal-function #'signal-process
"Name of signal function.
It can be an elisp function (usually `signal-process') or a string specifying
the external command (usually \"kill\")."
:type '(choice (function :tag "function")
(string :tag "command")))
+(make-obsolete-variable 'proced-signal-function "no longer used." "29.1")
(defcustom proced-renice-command "renice"
"Name of renice command."
@@ -275,8 +278,8 @@ It can also be a list of keys appearing in `proced-grammar-alist'."
;; FIXME: is there a better name for filter `user' that does not coincide
;; with an attribute key?
(defcustom proced-filter-alist
- `((user (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'")))
- (user-running (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'"))
+ `((user (user . proced-user-name))
+ (user-running (user . proced-user-name)
(state . "\\`[Rr]\\'"))
(all)
(all-running (state . "\\`[Rr]\\'"))
@@ -366,7 +369,7 @@ May be used to revert the process listing."
;; Internal variables
-(defvar proced-available (not (null (list-system-processes)))
+(defvar proced-available t;(not (null (list-system-processes)))
"Non-nil means Proced is known to work on this system.")
(defvar-local proced-process-alist nil
@@ -565,6 +568,12 @@ Important: the match ends just after the marker.")
:help "Renice Marked Processes"]))
;; helper functions
+(defun proced-user-name (user)
+ "Check the `user' attribute with user name `proced' is running for."
+ (string-equal user (if (file-remote-p default-directory)
+ (file-remote-p default-directory 'user)
+ (user-real-login-name))))
+
(defun proced-marker-regexp ()
"Return regexp matching `proced-marker-char'."
;; `proced-marker-char' must appear in column zero
@@ -626,6 +635,7 @@ Return nil if point is not on a process line."
Type \\[proced] to start a Proced session. In a Proced buffer
type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
Type \\[proced-send-signal] to send signals to marked processes.
+Type \\[proced-renice] to renice marked processes.
The initial content of a listing is defined by the variable `proced-filter'
and the variable `proced-format'.
@@ -677,8 +687,13 @@ After displaying or updating a Proced buffer, Proced runs the normal hook
(defun proced (&optional arg)
"Generate a listing of UNIX system processes.
\\<proced-mode-map>
-If invoked with optional ARG, do not select the window displaying
-the process information.
+If invoked with optional non-negative ARG, do not select the
+window displaying the process information.
+
+If `proced-show-remote-processes' is non-nil or the command is
+invoked with a negative ARG `\\[universal-argument] \\[negative-argument]', \
+and `default-directory'
+points to a remote host, the system processes of that host are shown.
This function runs the normal hook `proced-post-display-hook'.
@@ -689,6 +704,11 @@ Proced buffers."
(error "Proced is not available on this system"))
(let ((buffer (get-buffer-create "*Proced*")) new)
(set-buffer buffer)
+ (when (and (file-remote-p default-directory)
+ (not
+ (or proced-show-remote-processes
+ (eq arg '-))))
+ (setq default-directory temporary-file-directory))
(setq new (zerop (buffer-size)))
(when new
(proced-mode)
@@ -1406,7 +1426,7 @@ Replace newline characters by \"^J\" (two characters)."
;; If none of the alternatives is non-nil, the attribute is ignored
;; in the listing.
(let ((standard-attributes
- (car (proced-process-attributes (list (emacs-pid)))))
+ (car (proced-process-attributes (list-system-processes))))
new-format fmi)
(if (and proced-tree-flag
(assq 'ppid standard-attributes))
@@ -1821,7 +1841,8 @@ supported but discouraged. It will be removed in a future version of Emacs."
(dolist (process process-alist)
(condition-case err
(unless (zerop (funcall
- proced-signal-function (car process) signal))
+ proced-signal-function (car process) signal
+ (file-remote-p default-directory)))
(proced-log "%s\n" (cdr process))
(push (cdr process) failures))
(error ; catch errors from failed signals
@@ -1833,7 +1854,7 @@ supported but discouraged. It will be removed in a future version of Emacs."
(dolist (process process-alist)
(with-temp-buffer
(condition-case nil
- (unless (zerop (call-process
+ (unless (zerop (process-file
proced-signal-function nil t nil
signal (number-to-string (car process))))
(proced-log (current-buffer))
@@ -1875,7 +1896,7 @@ the normal hook `proced-after-send-signal-hook'."
(dolist (process process-alist)
(with-temp-buffer
(condition-case nil
- (unless (zerop (call-process
+ (unless (zerop (process-file
proced-renice-command nil t nil
priority (number-to-string (car process))))
(proced-log (current-buffer))
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index e9237bb01e2..f1f61f7e087 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -5026,18 +5026,6 @@ If a fill prefix is specified, it overrides all the above."
(defalias 'c-comment-line-break-function 'c-indent-new-comment-line)
(make-obsolete 'c-comment-line-break-function 'c-indent-new-comment-line "21.1")
-;; Advice for Emacsen older than 21.1 (!), released 2001/10
-(unless (boundp 'comment-line-break-function)
- (defvar c-inside-line-break-advice nil)
- (defadvice indent-new-comment-line (around c-line-break-advice
- activate preactivate)
- "Call `c-indent-new-comment-line' if in CC Mode."
- (if (or c-inside-line-break-advice
- (not c-buffer-is-cc-mode))
- ad-do-it
- (let ((c-inside-line-break-advice t))
- (c-indent-new-comment-line (ad-get-arg 0))))))
-
(defun c-context-line-break ()
"Do a line break suitable to the context.
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index ebc1ef43010..b2fa9e06911 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -6139,7 +6139,7 @@ comment at the start of cc-engine.el for more info."
(setq s (cons -1 (cdr s))))
((and (equal match ",")
(eq (car s) -1))) ; at "," in "class foo : bar, ..."
- ((member match '(";" "*" "," "("))
+ ((member match '(";" "*" "," ")"))
(when (and s (cdr s) (<= (car s) 0))
(setq s (cdr s))))
((c-keyword-member kwd-sym 'c-flat-decl-block-kwds)
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index ccc58e6773c..17905dec2eb 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -48,8 +48,8 @@ to avoid computing them again.")
"Set SYMBOL to VALUE, and update `grep-host-defaults-alist'.
SYMBOL should be one of `grep-command', `grep-template',
`grep-use-null-device', `grep-find-command' `grep-find-template',
-`grep-find-use-xargs', `grep-use-null-filename-separator', or
-`grep-highlight-matches'."
+`grep-find-use-xargs', `grep-use-null-filename-separator',
+`grep-highlight-matches', or `grep-quoting-style'."
(when grep-host-defaults-alist
(let* ((host-id
(intern (or (file-remote-p default-directory) "localhost")))
@@ -202,6 +202,9 @@ by `grep-compute-defaults'; to change the default value, use
:set #'grep-apply-setting
:version "22.1")
+(defvar grep-quoting-style nil
+ "Whether to use POSIX-like shell argument quoting.")
+
(defcustom grep-files-aliases
'(("all" . "* .*")
("el" . "*.el")
@@ -269,16 +272,16 @@ See `compilation-error-screen-columns'."
(defvar grep-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map compilation-minor-mode-map)
- (define-key map " " 'scroll-up-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map "\^?" 'scroll-down-command)
- (define-key map "\C-c\C-f" 'next-error-follow-minor-mode)
-
- (define-key map "\r" 'compile-goto-error) ;; ?
- (define-key map "{" 'compilation-previous-file)
- (define-key map "}" 'compilation-next-file)
- (define-key map "\t" 'compilation-next-error)
- (define-key map [backtab] 'compilation-previous-error)
+ (define-key map " " #'scroll-up-command)
+ (define-key map [?\S-\ ] #'scroll-down-command)
+ (define-key map "\^?" #'scroll-down-command)
+ (define-key map "\C-c\C-f" #'next-error-follow-minor-mode)
+
+ (define-key map "\r" #'compile-goto-error) ;; ?
+ (define-key map "{" #'compilation-previous-file)
+ (define-key map "}" #'compilation-next-file)
+ (define-key map "\t" #'compilation-next-error)
+ (define-key map [backtab] #'compilation-previous-error)
map)
"Keymap for grep buffers.
`compilation-minor-mode-map' is a cdr of this.")
@@ -322,24 +325,24 @@ See `compilation-error-screen-columns'."
;; FIXME: Nowadays the last button is not "help" but "search"!
(help (last tool-bar-map))) ;; Keep Help last in tool bar
(tool-bar-local-item
- "left-arrow" 'previous-error-no-select 'previous-error-no-select map
+ "left-arrow" #'previous-error-no-select #'previous-error-no-select map
:rtl "right-arrow"
:help "Goto previous match")
(tool-bar-local-item
- "right-arrow" 'next-error-no-select 'next-error-no-select map
+ "right-arrow" #'next-error-no-select #'next-error-no-select map
:rtl "left-arrow"
:help "Goto next match")
(tool-bar-local-item
- "cancel" 'kill-compilation 'kill-compilation map
+ "cancel" #'kill-compilation #'kill-compilation map
:enable '(let ((buffer (compilation-find-buffer)))
(get-buffer-process buffer))
:help "Stop grep")
(tool-bar-local-item
- "refresh" 'recompile 'recompile map
+ "refresh" #'recompile #'recompile map
:help "Restart grep")
(append map help))))
-(defalias 'kill-grep 'kill-compilation)
+(defalias 'kill-grep #'kill-compilation)
;; override compilation-last-buffer
(defvar grep-last-buffer nil
@@ -443,9 +446,9 @@ buffer `default-directory'."
(defvar grep-find-abbreviate-properties
(let ((ellipsis (if (char-displayable-p ?…) "[…]" "[...]"))
(map (make-sparse-keymap)))
- (define-key map [down-mouse-2] 'mouse-set-point)
- (define-key map [mouse-2] 'grep-find-toggle-abbreviation)
- (define-key map "\C-m" 'grep-find-toggle-abbreviation)
+ (define-key map [down-mouse-2] #'mouse-set-point)
+ (define-key map [mouse-2] #'grep-find-toggle-abbreviation)
+ (define-key map "\C-m" #'grep-find-toggle-abbreviation)
`(face nil display ,ellipsis mouse-face highlight
help-echo "RET, mouse-2: show unabbreviated command"
keymap ,map abbreviated-command t))
@@ -616,8 +619,8 @@ This function is called from `compilation-filter-hook'."
"Compute the defaults for the `grep' command.
The value depends on `grep-command', `grep-template',
`grep-use-null-device', `grep-find-command', `grep-find-template',
-`grep-use-null-filename-separator', `grep-find-use-xargs' and
-`grep-highlight-matches'."
+`grep-use-null-filename-separator', `grep-find-use-xargs',
+`grep-highlight-matches', and `grep-quoting-style'."
;; Keep default values.
(unless grep-host-defaults-alist
(add-to-list
@@ -631,13 +634,14 @@ The value depends on `grep-command', `grep-template',
(grep-use-null-filename-separator
,grep-use-null-filename-separator)
(grep-find-use-xargs ,grep-find-use-xargs)
- (grep-highlight-matches ,grep-highlight-matches)))))
- (let* ((host-id
- (intern (or (file-remote-p default-directory) "localhost")))
+ (grep-highlight-matches ,grep-highlight-matches)
+ (grep-quoting-style ,grep-quoting-style)))))
+ (let* ((remote (file-remote-p default-directory))
+ (host-id (intern (or remote "localhost")))
(host-defaults (assq host-id grep-host-defaults-alist))
(defaults (assq nil grep-host-defaults-alist))
- (quot-braces (shell-quote-argument "{}"))
- (quot-scolon (shell-quote-argument ";")))
+ (quot-braces (shell-quote-argument "{}" remote))
+ (quot-scolon (shell-quote-argument ";" remote)))
;; There are different defaults on different hosts. They must be
;; computed for every host once.
(dolist (setting '(grep-command grep-template
@@ -791,8 +795,11 @@ The value depends on `grep-command', `grep-template',
find-program gcmd null quot-braces))
(t
(format "%s -H <D> <X> -type f <F> -print | \"%s\" %s"
- find-program xargs-program gcmd))))))))
- ;; Save defaults for this host.
+ find-program xargs-program gcmd))))))
+
+ (setq grep-quoting-style (and remote 'posix))))
+
+ ;; Save defaults for this host.
(setq grep-host-defaults-alist
(delete (assq host-id grep-host-defaults-alist)
grep-host-defaults-alist))
@@ -807,7 +814,8 @@ The value depends on `grep-command', `grep-template',
(grep-use-null-filename-separator
,grep-use-null-filename-separator)
(grep-find-use-xargs ,grep-find-use-xargs)
- (grep-highlight-matches ,grep-highlight-matches))))))
+ (grep-highlight-matches ,grep-highlight-matches)
+ (grep-quoting-style ,grep-quoting-style))))))
(defun grep-tag-default ()
(or (and transient-mark-mode mark-active
@@ -820,7 +828,8 @@ The value depends on `grep-command', `grep-template',
(defun grep-default-command ()
"Compute the default grep command for \\[universal-argument] \\[grep] to offer."
- (let ((tag-default (shell-quote-argument (grep-tag-default)))
+ (let ((tag-default
+ (shell-quote-argument (grep-tag-default) grep-quoting-style))
;; This a regexp to match single shell arguments.
;; Could someone please add comments explaining it?
(sh-arg-re
@@ -952,8 +961,7 @@ easily repeat a find command."
(grep command-args))))
;;;###autoload
-(defalias 'find-grep 'grep-find)
-
+(defalias 'find-grep #'grep-find)
;; User-friendly interactive API.
@@ -963,7 +971,7 @@ easily repeat a find command."
("<F>" . files)
("<N>" . (null-device))
("<X>" . excl)
- ("<R>" . (shell-quote-argument (or regexp ""))))
+ ("<R>" . (shell-quote-argument (or regexp "") grep-quoting-style)))
"List of substitutions performed by `grep-expand-template'.
If car of an element matches, the cdr is evalled in order to get the
substitution string.
@@ -1010,7 +1018,7 @@ these include `opts', `dir', `files', `null-device', `excl' and
;; Instead of a `grep-read-files-function' variable, we used to lookup
;; mode-specific functions in the major mode's symbol properties, so preserve
;; this behavior for backward compatibility.
- (let ((old-function (get major-mode 'grep-read-files))) ;Obsolete since 28.1
+ (let ((old-function (get major-mode #'grep-read-files))) ;Obsolete since 28.1
(if old-function
(funcall old-function)
(let ((file-name-at-point
@@ -1112,6 +1120,9 @@ command before it's run."
(when (and (stringp regexp) (> (length regexp) 0))
(unless (and dir (file-accessible-directory-p dir))
(setq dir default-directory))
+ (unless (string-equal (file-remote-p dir) (file-remote-p default-directory))
+ (let ((default-directory dir))
+ (grep-compute-defaults)))
(let ((command regexp))
(if (null files)
(if (string= command grep-command)
@@ -1134,11 +1145,13 @@ command before it's run."
(mapconcat
(lambda (ignore)
(cond ((stringp ignore)
- (shell-quote-argument ignore))
+ (shell-quote-argument
+ ignore grep-quoting-style))
((consp ignore)
(and (funcall (car ignore) dir)
(shell-quote-argument
- (cdr ignore))))))
+ (cdr ignore)
+ grep-quoting-style)))))
grep-find-ignored-files
" --exclude=")))
(and (eq grep-use-directories-skip t)
@@ -1158,7 +1171,7 @@ command before it's run."
(if (and grep-use-null-device null-device (null-device))
(concat command " " (null-device))
command)
- 'grep-mode))
+ #'grep-mode))
;; Set default-directory if we started lgrep in the *grep* buffer.
(if (eq next-error-last-buffer (current-buffer))
(setq default-directory dir))))))
@@ -1210,11 +1223,14 @@ command before it's run."
(when (and (stringp regexp) (> (length regexp) 0))
(unless (and dir (file-accessible-directory-p dir))
(setq dir default-directory))
+ (unless (string-equal (file-remote-p dir) (file-remote-p default-directory))
+ (let ((default-directory dir))
+ (grep-compute-defaults)))
(if (null files)
(if (not (string= regexp (if (consp grep-find-command)
(car grep-find-command)
grep-find-command)))
- (compilation-start regexp 'grep-mode))
+ (compilation-start regexp #'grep-mode))
(setq dir (file-name-as-directory (expand-file-name dir)))
(let ((command (rgrep-default-command regexp files nil)))
(when command
@@ -1225,7 +1241,7 @@ command before it's run."
(add-to-history 'grep-find-history command))
(grep--save-buffers)
(let ((default-directory dir))
- (compilation-start command 'grep-mode))
+ (compilation-start command #'grep-mode))
;; Set default-directory if we started rgrep in the *grep* buffer.
(if (eq next-error-last-buffer (current-buffer))
(setq default-directory dir)))))))
@@ -1245,44 +1261,46 @@ command before it's run."
(grep-expand-template
grep-find-template
regexp
- (concat (shell-quote-argument "(")
+ (concat (shell-quote-argument "(" grep-quoting-style)
" " find-name-arg " "
(mapconcat
- #'shell-quote-argument
+ (lambda (x) (shell-quote-argument x grep-quoting-style))
(split-string files)
(concat " -o " find-name-arg " "))
" "
- (shell-quote-argument ")"))
+ (shell-quote-argument ")" grep-quoting-style))
dir
(concat
(and grep-find-ignored-directories
(concat "-type d "
- (shell-quote-argument "(")
+ (shell-quote-argument "(" grep-quoting-style)
;; we should use shell-quote-argument here
" -path "
- (mapconcat (lambda (d) (shell-quote-argument (concat "*/" d)))
- (rgrep-find-ignored-directories dir)
- " -o -path ")
+ (mapconcat
+ (lambda (d)
+ (shell-quote-argument (concat "*/" d) grep-quoting-style))
+ (rgrep-find-ignored-directories dir)
+ " -o -path ")
" "
- (shell-quote-argument ")")
+ (shell-quote-argument ")" grep-quoting-style)
" -prune -o "))
(and grep-find-ignored-files
- (concat (shell-quote-argument "!") " -type d "
- (shell-quote-argument "(")
+ (concat (shell-quote-argument "!" grep-quoting-style) " -type d "
+ (shell-quote-argument "(" grep-quoting-style)
;; we should use shell-quote-argument here
" -name "
(mapconcat
(lambda (ignore)
(cond ((stringp ignore)
- (shell-quote-argument ignore))
+ (shell-quote-argument ignore grep-quoting-style))
((consp ignore)
(and (funcall (car ignore) dir)
(shell-quote-argument
- (cdr ignore))))))
+ (cdr ignore) grep-quoting-style)))))
grep-find-ignored-files
" -o -name ")
" "
- (shell-quote-argument ")")
+ (shell-quote-argument ")" grep-quoting-style)
" -prune -o ")))))
(defun grep-find-toggle-abbreviation ()
@@ -1352,7 +1370,7 @@ The returned file name is relative."
(caar (compilation--loc->file-struct loc))))
;;;###autoload
-(defalias 'rzgrep 'zrgrep)
+(defalias 'rzgrep #'zrgrep)
(provide 'grep)
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index eb54ffe05a8..fdc8164dc0b 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -70,7 +70,7 @@
"Regexp to match modifiers.")
(defconst ruby-block-mid-keywords
- '("then" "else" "elsif" "when" "rescue" "ensure")
+ '("then" "else" "elsif" "when" "in" "rescue" "ensure")
"Keywords where the indentation gets shallower in middle of block statements.")
(defconst ruby-block-mid-re
@@ -369,7 +369,9 @@ This only affects the output of the command `ruby-toggle-block'."
(for-body (for-head ";" insts))
(for-head (id "in" exp))
(cases (exp "then" insts)
- (cases "when" cases) (insts "else" insts))
+ (cases "when" cases)
+ (cases "in" cases)
+ (insts "else" insts))
(expseq (exp) );;(expseq "," expseq)
(hashvals (exp1 "=>" exp1) (hashvals "," hashvals))
(insts-rescue-insts (insts)
@@ -380,7 +382,7 @@ This only affects the output of the command `ruby-toggle-block'."
(if-body (ielsei) (if-body "elsif" if-body)))
'((nonassoc "in") (assoc ";") (right " @ ")
(assoc ",") (right "="))
- '((assoc "when"))
+ '((assoc "when" "in"))
'((assoc "elsif"))
'((assoc "rescue" "ensure"))
'((assoc ",")))
@@ -595,7 +597,7 @@ This only affects the output of the command `ruby-toggle-block'."
(cond
((smie-rule-parent-p "def" "begin" "do" "class" "module" "for"
"while" "until" "unless"
- "if" "then" "elsif" "else" "when"
+ "if" "then" "elsif" "else" "when" "in"
"rescue" "ensure" "{")
(smie-rule-parent ruby-indent-level))
;; For (invalid) code between switch and case.
@@ -659,7 +661,7 @@ This only affects the output of the command `ruby-toggle-block'."
ruby-indent-level))))
(`(:before . ,(or "else" "then" "elsif" "rescue" "ensure"))
(smie-rule-parent))
- ('(:before . "when")
+ (`(:before . ,(or "when" "in"))
;; Align to the previous `when', but look up the virtual
;; indentation of `case'.
(if (smie-rule-sibling-p) 0 (smie-rule-parent)))
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index 8dc55621438..9151fd0a340 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1549,7 +1549,7 @@ with your script for an edit-interpret-debug cycle."
;; Checks that use `buffer-file-name' follow.
((string-match "\\.m?spec\\'" buffer-file-name) "rpm")
((string-match "[.]sh\\>" buffer-file-name) "sh")
- ((string-match "[.]bash\\>" buffer-file-name) "bash")
+ ((string-match "[.]bash\\(rc\\)?\\>" buffer-file-name) "bash")
((string-match "[.]ksh\\>" buffer-file-name) "ksh")
((string-match "[.]mkshrc\\>" buffer-file-name) "mksh")
((string-match "[.]t?csh\\(rc\\)?\\>" buffer-file-name) "csh")
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 69d16a4357e..13fba0c7058 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -4195,7 +4195,18 @@ must tell Emacs. Here's how to do that in your init file:
nil)))
;; Propertize rules to not have /- and -* start comments.
("\\(/-\\)" (1 "."))
- ("\\(-\\*\\)" (1 "."))))
+ ("\\(-\\*\\)"
+ (1
+ (if (save-excursion
+ (not (ppss-comment-depth
+ (syntax-ppss (match-beginning 1)))))
+ ;; If we're outside a comment, we don't let -*
+ ;; start a comment.
+ (string-to-syntax ".")
+ ;; Inside a comment, ignore it to avoid -*/ not
+ ;; being intepreted as a comment end.
+ (forward-char -1)
+ nil)))))
;; 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/progmodes/xref.el b/lisp/progmodes/xref.el
index 5d1ba4eaf55..277934c08a2 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1715,7 +1715,8 @@ IGNORES is a list of glob patterns for files to ignore."
.
;; '!*/' is there to filter out dirs (e.g. submodules).
"xargs -0 rg <C> --null -nH --no-heading --no-messages -g '!*/' -e <R>"
- ))
+ )
+ (ugrep . "xargs -0 ugrep <C> --null -ns -e <R>"))
"Associative list mapping program identifiers to command templates.
Program identifier should be a symbol, named after the search program.
@@ -1744,6 +1745,7 @@ utility function used by commands like `dired-do-find-regexp' and
:type '(choice
(const :tag "Use Grep" grep)
(const :tag "Use ripgrep" ripgrep)
+ (const :tag "Use ugrep" ugrep)
(symbol :tag "User defined"))
:version "28.1"
:package-version '(xref . "1.0.4"))
diff --git a/lisp/replace.el b/lisp/replace.el
index 06be5978554..00d30d1e383 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -365,11 +365,33 @@ should a regexp."
(unless noerror
(barf-if-buffer-read-only))
(save-mark-and-excursion
- (let* ((from (query-replace-read-from prompt regexp-flag))
+ (let* ((delimited-flag (and current-prefix-arg
+ (not (eq current-prefix-arg '-))))
+ (from (minibuffer-with-setup-hook
+ (minibuffer-lazy-highlight-setup
+ :case-fold case-fold-search
+ :filter (when (use-region-p)
+ (replace--region-filter
+ (funcall region-extract-function 'bounds)))
+ :highlight query-replace-lazy-highlight
+ :regexp regexp-flag
+ :regexp-function (or replace-regexp-function
+ delimited-flag
+ (and replace-char-fold
+ (not regexp-flag)
+ #'char-fold-to-regexp))
+ :transform (lambda (string)
+ (let* ((split (query-replace--split-string string))
+ (from-string (if (consp split) (car split) split)))
+ (when (and case-fold-search search-upper-case)
+ (setq isearch-case-fold-search
+ (isearch-no-upper-case-p from-string regexp-flag)))
+ from-string)))
+ (query-replace-read-from prompt regexp-flag)))
(to (if (consp from) (prog1 (cdr from) (setq from (car from)))
(query-replace-read-to from prompt regexp-flag))))
(list from to
- (or (and current-prefix-arg (not (eq current-prefix-arg '-)))
+ (or delimited-flag
(and (plist-member (text-properties-at 0 from) 'isearch-regexp-function)
(get-text-property 0 'isearch-regexp-function from)))
(and current-prefix-arg (eq current-prefix-arg '-))))))
@@ -2685,6 +2707,11 @@ to a regexp that is actually used for the search.")
(or (if regexp-flag
replace-re-search-function
replace-search-function)
+ ;; `isearch-search-fun' can't be used here because
+ ;; when buffer-local `isearch-search-fun-function'
+ ;; searches e.g. the minibuffer history, then
+ ;; `query-replace' should not operate on the whole
+ ;; history, but only on the minibuffer contents.
(isearch-search-fun-default))))
(funcall search-function search-string limit t)))
@@ -2773,6 +2800,26 @@ to a regexp that is actually used for the search.")
,search-str ,next-replace)
,stack))
+(defun replace--region-filter (bounds)
+ "Return a function that decides if a region is inside BOUNDS.
+BOUNDS is a list of cons cells of the form (START . END). The
+returned function takes as argument two buffer positions, START
+and END."
+ (let ((region-bounds
+ (mapcar (lambda (position)
+ (cons (copy-marker (car position))
+ (copy-marker (cdr position))))
+ bounds)))
+ (lambda (start end)
+ (delq nil (mapcar
+ (lambda (bounds)
+ (and
+ (>= start (car bounds))
+ (<= start (cdr bounds))
+ (>= end (car bounds))
+ (<= end (cdr bounds))))
+ region-bounds)))))
+
(defun perform-replace (from-string replacements
query-flag regexp-flag delimited-flag
&optional repeat-count map start end backward region-noncontiguous-p)
@@ -2857,22 +2904,9 @@ characters."
;; Unless a single contiguous chunk is selected, operate on multiple chunks.
(when region-noncontiguous-p
- (let ((region-bounds
- (mapcar (lambda (position)
- (cons (copy-marker (car position))
- (copy-marker (cdr position))))
- (funcall region-extract-function 'bounds))))
- (setq region-filter
- (lambda (start end)
- (delq nil (mapcar
- (lambda (bounds)
- (and
- (>= start (car bounds))
- (<= start (cdr bounds))
- (>= end (car bounds))
- (<= end (cdr bounds))))
- region-bounds))))
- (add-function :after-while isearch-filter-predicate region-filter)))
+ (setq region-filter (replace--region-filter
+ (funcall region-extract-function 'bounds)))
+ (add-function :after-while isearch-filter-predicate region-filter))
;; If region is active, in Transient Mark mode, operate on region.
(if backward
diff --git a/lisp/select.el b/lisp/select.el
index e9bc5451171..3646a28b9b4 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -25,9 +25,10 @@
;; Based partially on earlier release by Lucid.
;; The functionality here is divided in two parts:
-;; - Low-level: gui-get-selection, gui-set-selection, gui-selection-owner-p,
-;; gui-selection-exists-p are the backend-dependent functions meant to access
-;; various kinds of selections (CLIPBOARD, PRIMARY, SECONDARY).
+;; - Low-level: gui-backend-get-selection, gui-backend-set-selection,
+;; gui-backend-selection-owner-p, gui-backend-selection-exists-p are
+;; the backend-dependent functions meant to access various kinds of
+;; selections (CLIPBOARD, PRIMARY, SECONDARY).
;; - Higher-level: gui-select-text and gui-selection-value go together to
;; access the general notion of "GUI selection" for interoperation with other
;; applications. This can use either the clipboard or the primary selection,
@@ -108,9 +109,10 @@ E.g. it doesn't exist under MS-Windows."
:group 'killing
:version "25.1")
-;; We keep track of the last text selected here, so we can check the
-;; current selection against it, and avoid passing back our own text
-;; from gui-selection-value. We track both
+;; We keep track of the last selection here, so we can check the
+;; current selection against it, and avoid passing back with
+;; gui-selection-value the same text we previously killed or
+;; yanked. We track both
;; separately in case another X application only sets one of them
;; we aren't fooled by the PRIMARY or CLIPBOARD selection staying the same.
@@ -119,22 +121,68 @@ E.g. it doesn't exist under MS-Windows."
(defvar gui--last-selected-text-primary nil
"The value of the PRIMARY selection last seen.")
+(defvar gui--last-selection-timestamp-clipboard nil
+ "The timestamp of the CLIPBOARD selection last seen.")
+(defvar gui--last-selection-timestamp-primary nil
+ "The timestamp of the PRIMARY selection last seen.")
+
+(defun gui--set-last-clipboard-selection (text)
+ "Save last clipboard selection.
+Save the selected text, passed as argument, and for window
+systems that support it, save the selection timestamp too."
+ (setq gui--last-selected-text-clipboard text)
+ (when (eq window-system 'x)
+ (setq gui--last-selection-timestamp-clipboard
+ (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP))))
+
+(defun gui--set-last-primary-selection (text)
+ "Save last primary selection.
+Save the selected text, passed as argument, and for window
+systems that support it, save the selection timestamp too."
+ (setq gui--last-selected-text-primary text)
+ (when (eq window-system 'x)
+ (setq gui--last-selection-timestamp-primary
+ (gui-backend-get-selection 'PRIMARY 'TIMESTAMP))))
+
+(defun gui--clipboard-selection-unchanged-p (text)
+ "Check whether the clipboard selection has changed.
+Compare the selection text, passed as argument, with the text
+from the last saved selection. For window systems that support
+it, compare the selection timestamp too."
+ (and
+ (equal text gui--last-selected-text-clipboard)
+ (or (not (eq window-system 'x))
+ (eq gui--last-selection-timestamp-clipboard
+ (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP)))))
+
+(defun gui--primary-selection-unchanged-p (text)
+ "Check whether the primary selection has changed.
+Compare the selection text, passed as argument, with the text
+from the last saved selection. For window systems that support
+it, compare the selection timestamp too."
+ (and
+ (equal text gui--last-selected-text-primary)
+ (or (not (eq window-system 'x))
+ (eq gui--last-selection-timestamp-primary
+ (gui-backend-get-selection 'PRIMARY 'TIMESTAMP)))))
+
+
(defun gui-select-text (text)
"Select TEXT, a string, according to the window system.
-if `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard.
+If `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard.
If `select-enable-primary' is non-nil, put TEXT in the primary selection.
MS-Windows does not have a \"primary\" selection."
(when select-enable-primary
(gui-set-selection 'PRIMARY text)
- (setq gui--last-selected-text-primary text))
+ (gui--set-last-primary-selection text))
(when select-enable-clipboard
;; When cutting, the selection is cleared and PRIMARY
;; set to the empty string. Prevent that, PRIMARY
;; should not be reset by cut (Bug#16382).
(setq saved-region-selection text)
(gui-set-selection 'CLIPBOARD text)
- (setq gui--last-selected-text-clipboard text)))
+ (gui--set-last-clipboard-selection text)))
(define-obsolete-function-alias 'x-select-text 'gui-select-text "25.1")
(defcustom x-select-request-type nil
@@ -175,6 +223,7 @@ decoded. If `gui-get-selection' signals an error, return nil."
;; some other window systems.
(memq window-system '(x haiku))
(eq type 'CLIPBOARD)
+ ;; Should we unify this with gui--clipboard-selection-unchanged-p?
(gui-backend-selection-owner-p type))
(let ((request-type (if (memq window-system '(x pgtk haiku))
(or x-select-request-type
@@ -197,19 +246,17 @@ decoded. If `gui-get-selection' signals an error, return nil."
(let ((text (gui--selection-value-internal 'CLIPBOARD)))
(when (string= text "")
(setq text nil))
- ;; When `select-enable-clipboard' is non-nil,
- ;; killing/copying text (with, say, `C-w') will push the
- ;; text to the clipboard (and store it in
- ;; `gui--last-selected-text-clipboard'). We check
- ;; whether the text on the clipboard is identical to this
- ;; text, and if so, we report that the clipboard is
- ;; empty. See (bug#27442) for further discussion about
- ;; this DWIM action, and possible ways to make this check
- ;; less fragile, if so desired.
- (prog1
- (unless (equal text gui--last-selected-text-clipboard)
- text)
- (setq gui--last-selected-text-clipboard text)))))
+ ;; Check the CLIPBOARD selection for 'newness', i.e.,
+ ;; whether it is different from the last time we did a
+ ;; yank operation or whether it was set by Emacs itself
+ ;; with a kill operation, since in both cases the text
+ ;; will already be in the kill ring. See (bug#27442) and
+ ;; (bug#53894) for further discussion about this DWIM
+ ;; action, and possible ways to make this check less
+ ;; fragile, if so desired.
+ (unless (gui--clipboard-selection-unchanged-p text)
+ (gui--set-last-clipboard-selection text)
+ text))))
(primary-text
(when select-enable-primary
(let ((text (gui--selection-value-internal 'PRIMARY)))
@@ -217,10 +264,9 @@ decoded. If `gui-get-selection' signals an error, return nil."
;; Check the PRIMARY selection for 'newness', is it different
;; from what we remembered them to be last time we did a
;; cut/paste operation.
- (prog1
- (unless (equal text gui--last-selected-text-primary)
- text)
- (setq gui--last-selected-text-primary text))))))
+ (unless (gui--primary-selection-unchanged-p text)
+ (gui--set-last-primary-selection text)
+ text)))))
;; As we have done one selection, clear this now.
(setq next-selection-coding-system nil)
@@ -235,11 +281,11 @@ decoded. If `gui-get-selection' signals an error, return nil."
;; something like the following has happened since the last time
;; we looked at the selections: Application X set all the
;; selections, then Application Y set only one of them.
- ;; In this case since we don't have
- ;; timestamps there is no way to know what the 'correct' value to
- ;; return is. The nice thing to do would be to tell the user we
- ;; saw multiple possible selections and ask the user which was the
- ;; one they wanted.
+ ;; In this case, for systems that support selection timestamps, we
+ ;; could return the newer. For systems that don't, there is no
+ ;; way to know what the 'correct' value to return is. The nice
+ ;; thing to do would be to tell the user we saw multiple possible
+ ;; selections and ask the user which was the one they wanted.
(or clip-text primary-text)
))
@@ -350,10 +396,10 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'."
(defun gui-set-selection (type data)
"Make an X selection of type TYPE and value DATA.
The argument TYPE (nil means `PRIMARY') says which selection, and
-DATA specifies the contents. TYPE must be a symbol. \(It can also
-be a string, which stands for the symbol with that name, but this
-is considered obsolete.) DATA may be a string, a symbol, an
-integer (or a cons of two integers or list of two integers).
+DATA specifies the contents. TYPE must be a symbol. \(It can
+also be a string, which stands for the symbol with that name, but
+this is considered obsolete.) DATA may be a string, a symbol, or
+an integer.
The selection may also be a cons of two markers pointing to the same buffer,
or an overlay. In these cases, the selection is considered to be the text
@@ -546,31 +592,36 @@ two markers or an overlay. Otherwise, it is nil."
(if len
(xselect--int-to-cons len))))
-(defun xselect-convert-to-targets (_selection _type _value)
- ;; return a vector of atoms, but remove duplicates first.
- (let* ((all (cons 'TIMESTAMP
- (cons 'MULTIPLE
- (mapcar 'car selection-converter-alist))))
- (rest all))
- (while rest
- (cond ((memq (car rest) (cdr rest))
- (setcdr rest (delq (car rest) (cdr rest))))
- ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
- (setcdr rest (cdr (cdr rest))))
- (t
- (setq rest (cdr rest)))))
- (apply 'vector all)))
+(defun xselect-convert-to-targets (selection _type value)
+ ;; Return a vector of atoms, but remove duplicates first.
+ (apply #'vector
+ (delete-dups
+ `( TIMESTAMP MULTIPLE
+ . ,(delq '_EMACS_INTERNAL
+ (mapcar (lambda (conv)
+ (if (or (not (consp (cdr conv)))
+ (funcall (cadr conv) selection
+ (car conv) value))
+ (car conv)
+ '_EMACS_INTERNAL))
+ selection-converter-alist))))))
(defun xselect-convert-to-delete (selection _type _value)
- (gui-backend-set-selection selection nil)
+ ;; This should be handled by the caller of `x-begin-drag'.
+ (unless (eq selection 'XdndSelection)
+ (gui-backend-set-selection selection nil))
;; A return value of nil means that we do not know how to do this conversion,
;; and replies with an "error". A return value of NULL means that we have
;; done the conversion (and any side-effects) but have no value to return.
'NULL)
-(defun xselect-convert-to-filename (_selection _type value)
- (when (setq value (xselect--selection-bounds value))
- (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value)))))
+(defun xselect-convert-to-filename (selection _type value)
+ (if (not (eq selection 'XdndSelection))
+ (when (setq value (xselect--selection-bounds value))
+ (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value))))
+ (when (and (stringp value)
+ (file-exists-p value))
+ (xselect--encode-string 'C_STRING value))))
(defun xselect-convert-to-charpos (_selection _type value)
(when (setq value (xselect--selection-bounds value))
@@ -632,6 +683,40 @@ This function returns the string \"emacs\"."
(when (eq selection 'CLIPBOARD)
'NULL))
+(defun xselect-convert-to-username (_selection _type _value)
+ (user-real-login-name))
+
+(defun xselect-convert-to-text-uri-list (_selection _type value)
+ (when (and (stringp value)
+ (file-exists-p value))
+ (concat (url-encode-url
+ ;; Uncomment the following code code in a better world where
+ ;; people write correct code that adds the hostname to the URI.
+ ;; Since most programs don't implement this properly, we omit the
+ ;; hostname so that copying files actually works. Most properly
+ ;; written programs will look at WM_CLIENT_MACHINE to determine
+ ;; the hostname anyway. (format "file://%s%s\n" (system-name)
+ ;; (expand-file-name value))
+ (concat "file://" (expand-file-name value)))
+ "\n")))
+
+(defun xselect-convert-to-xm-file (selection _type value)
+ (when (and (stringp value)
+ (file-exists-p value)
+ (eq selection 'XdndSelection))
+ (xselect--encode-string 'C_STRING
+ (concat value [0]))))
+
+(defun xselect-uri-list-available-p (selection _type value)
+ "Return whether or not `text/uri-list' is a valid target for SELECTION.
+VALUE is the local selection value of SELECTION."
+ (and (eq selection 'XdndSelection)
+ (stringp value)
+ (file-exists-p value)))
+
+(defun xselect-convert-xm-special (_selection _type _value)
+ "")
+
(setq selection-converter-alist
'((TEXT . xselect-convert-to-string)
(COMPOUND_TEXT . xselect-convert-to-string)
@@ -639,6 +724,9 @@ This function returns the string \"emacs\"."
(UTF8_STRING . xselect-convert-to-string)
(text/plain . xselect-convert-to-string)
(text/plain\;charset=utf-8 . xselect-convert-to-string)
+ (text/uri-list . (xselect-uri-list-available-p . xselect-convert-to-text-uri-list))
+ (text/x-xdnd-username . xselect-convert-to-username)
+ (FILE . (xselect-uri-list-available-p . xselect-convert-to-xm-file))
(TARGETS . xselect-convert-to-targets)
(LENGTH . xselect-convert-to-length)
(DELETE . xselect-convert-to-delete)
@@ -654,7 +742,9 @@ This function returns the string \"emacs\"."
(ATOM . xselect-convert-to-atom)
(INTEGER . xselect-convert-to-integer)
(SAVE_TARGETS . xselect-convert-to-save-targets)
- (_EMACS_INTERNAL . xselect-convert-to-identity)))
+ (_EMACS_INTERNAL . xselect-convert-to-identity)
+ (XmTRANSFER_SUCCESS . xselect-convert-xm-special)
+ (XmTRANSFER_FAILURE . xselect-convert-xm-special)))
(provide 'select)
diff --git a/lisp/server.el b/lisp/server.el
index da60f1cda77..763cf27f7ac 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -779,7 +779,8 @@ by the current Emacs process, use the `server-process' variable."
(condition-case nil
(if server-use-tcp
(with-temp-buffer
- (insert-file-contents-literally (expand-file-name name server-auth-dir))
+ (setq default-directory server-auth-dir)
+ (insert-file-contents-literally (expand-file-name name))
(or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)")
(assq 'comm
(process-attributes
diff --git a/lisp/ses.el b/lisp/ses.el
index 45e323e8051..59e10e777f1 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -84,17 +84,14 @@
(defcustom ses-initial-size '(1 . 1)
"Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)."
- :group 'ses
:type '(cons (integer :tag "numrows") (integer :tag "numcols")))
(defcustom ses-initial-column-width 7
"Initial width of columns in a new spreadsheet."
- :group 'ses
:type '(integer :match (lambda (widget value) (> value 0))))
(defcustom ses-initial-default-printer "%.7g"
"Initial default printer for a new spreadsheet."
- :group 'ses
:type '(choice string
(list :tag "Parenthesized string" string)
function))
@@ -103,15 +100,30 @@
"Things to do after entering a value into a cell.
An abnormal hook that usually runs a cursor-movement function.
Each function is called with ARG=1."
- :group 'ses
:type 'hook
:options '(forward-char backward-char next-line previous-line))
(defcustom ses-mode-hook nil
"Hook functions to be run upon entering SES mode."
- :group 'ses
:type 'hook)
+(defcustom ses-jump-cell-name-function #'upcase
+ "Function to process the string passed to function ‘ses-jump’.
+Set it to 'identity to make no change.
+Set it to 'upcase to make cell name change case isensitive.
+
+ May return
+
+* a string, in this case this must be a cell name.
+* a (row . col) cons cell, in this case that must be valid cell coordinates."
+ :type 'function)
+
+(defcustom ses-jump-prefix-function #'ses-jump-prefix
+ "Function that takes the prefix argument passed to function ‘ses-jump’.
+It may return the same sort of thing as ‘ses-jump-cell-name-function’."
+ :type 'function)
+
+
;;----------------------------------------------------------------------------
;; Global variables and constants
@@ -233,7 +245,7 @@ Used for listing local printers or renamed cells.")
(suppress-keymap newmap t)
;;These keys insert themselves as the beginning of a numeric value
(dotimes (x (length numeric))
- (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell))
+ (define-key newmap (substring numeric x (1+ x)) #'ses-read-cell))
(define-key newmap [remap clipboard-kill-region] #'ses-kill-override)
(define-key newmap [remap end-of-line] #'ses-end-of-line)
(define-key newmap [remap kill-line] #'ses-delete-row)
@@ -345,7 +357,7 @@ printer and then modify its output.")
(t (error "Unexpected elements `%S' in list `ses-localvars'" x)))))
;;; This variable is documented as being permitted in file-locals:
-(put 'ses--symbolic-formulas 'safe-local-variable 'consp)
+(put 'ses--symbolic-formulas 'safe-local-variable #'consp)
(defconst ses-paramlines-plist
'(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3
@@ -1056,8 +1068,7 @@ the old and FORCE is nil."
(defcustom ses-self-reference-early-detection nil
"Non-nil if cycle detection is early for cells that refer to themselves."
:version "24.1"
- :type 'boolean
- :group 'ses)
+ :type 'boolean)
(defun ses-update-cells (list &optional force)
"Recalculate cells in LIST, checking for dependency loops.
@@ -2064,8 +2075,8 @@ formula:
;; Not to use tab characters for safe (tabs may do bad for column
;; calculation).
indent-tabs-mode nil)
- (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t))
- (1value (add-hook 'kill-buffer-hook 'ses-killbuffer-hook nil t))
+ (1value (add-hook 'change-major-mode-hook #'ses-cleanup nil t))
+ (1value (add-hook 'kill-buffer-hook #'ses-killbuffer-hook nil t))
(cl-pushnew (current-buffer) ses--ses-buffer-list :test 'eq)
;; This makes revert impossible if the buffer is read-only.
;; (1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
@@ -2116,8 +2127,8 @@ formula:
;; find-alternate-file, post-command-hook doesn't get run for some reason,
;; so use an idle timer to make sure.
(setq ses--deferred-narrow 'ses-mode)
- (1value (add-hook 'post-command-hook 'ses-command-hook nil t))
- (run-with-idle-timer 0.01 nil 'ses-command-hook)
+ (1value (add-hook 'post-command-hook #'ses-command-hook nil t))
+ (run-with-idle-timer 0.01 nil #'ses-command-hook)
(run-mode-hooks 'ses-mode-hook)))
(put 'ses-mode 'mode-class 'special)
@@ -2233,24 +2244,43 @@ Based on the current set of columns and `window-hscroll' position."
;;----------------------------------------------------------------------------
;; Redisplay and recalculation
;;----------------------------------------------------------------------------
+(defun ses-jump-prefix (prefix-int)
+ "Convert an integer (unversal prefix) into a (ROW . COL).
+Does it by numbering cells starting from 0 from top left to bottom right,
+going row by row."
+ (and (>= prefix-int 0)
+ (< prefix-int (* ses--numcols ses--numrows))
+ (cons (/ prefix-int ses--numcols) (% prefix-int ses--numcols))))
+
-(defun ses-jump (sym)
+(defun ses-jump (&optional sym)
"Move point to cell SYM."
- (interactive (let* (names
- (s (completing-read
- "Jump to cell: "
- (and ses--named-cell-hashmap
- (progn (maphash (lambda (key _val)
- (push (symbol-name key) names))
- ses--named-cell-hashmap)
- names)))))
- (if (string= s "")
- (user-error "Invalid cell name")
- (list (intern s)))))
- (let ((rowcol (ses-sym-rowcol sym)))
+ (interactive "P")
+ (setq sym
+ (if current-prefix-arg
+ (funcall ses-jump-prefix-function (prefix-numeric-value sym))
+ (or sym
+ (completing-read
+ "Jump to cell: "
+ (and ses--named-cell-hashmap
+ (let (names)
+ (maphash (lambda (key _val)
+ (push (symbol-name key) names))
+ ses--named-cell-hashmap)
+ names))))))
+ (and (stringp sym)
+ (not (and ses--named-cell-hashmap (gethash (intern sym) ses--named-cell-hashmap)))
+ (setq sym (funcall ses-jump-cell-name-function sym)))
+ (if (stringp sym)
+ (if (string= sym "")
+ (user-error "Empty cell name")
+ (setq sym (intern sym))))
+ (let ((rowcol (if (consp sym)
+ (prog1 sym (setq sym (ses-cell-symbol (car sym) (cdr sym))))
+ (ses-sym-rowcol sym))))
(or rowcol (error "Invalid cell name"))
(if (eq (symbol-value sym) '*skip*)
- (error "Cell is covered by preceding cell"))
+ (error "Cell is covered by preceding cell"))
(ses-goto-print (car rowcol) (cdr rowcol))))
(defun ses-jump-safe (cell)
@@ -2507,7 +2537,7 @@ Return nil if cell formula was unsafe and user declined confirmation."
;; Position cursor inside close-quote.
(setq initial (cons initial (length initial))))
(dolist (key ses-completion-keys)
- (define-key ses-mode-edit-map key 'ses-edit-cell-complete-symbol))
+ (define-key ses-mode-edit-map key #'ses-edit-cell-complete-symbol))
;; make it globally visible, so that it can be visible from the minibuffer.
(setq ses--completion-table ses--named-cell-hashmap)
(list row col
@@ -2604,8 +2634,9 @@ With prefix, deletes several cells."
;;----------------------------------------------------------------------------
(defun ses-read-printer-complete-symbol ()
(interactive)
- (let ((completion-at-point-functions (cons 'ses--read-printer-completion-at-point-function
- completion-at-point-functions)))
+ (let ((completion-at-point-functions
+ (cons #'ses--read-printer-completion-at-point-function
+ completion-at-point-functions)))
(completion-at-point)))
(defun ses--read-printer-completion-at-point-function ()
@@ -2647,7 +2678,7 @@ canceled."
(setq default "")
(setq prompt (format-prompt prompt default)))
(dolist (key ses-completion-keys)
- (define-key ses-mode-edit-map key 'ses-read-printer-complete-symbol))
+ (define-key ses-mode-edit-map key #'ses-read-printer-complete-symbol))
;; make it globally visible, so that it can be visible from the minibuffer.
(setq ses--completion-table ses--local-printer-hashmap)
(let ((new (read-from-minibuffer prompt
@@ -4079,13 +4110,15 @@ SPAN indicates how many rightward columns to include in width (default = 0)."
(ses-center value span ?- printer))
(defun ses-dashfill-span (value &optional printer)
- "Print VALUE, centered using dashes within the span that starts in the
-current column and continues until the next nonblank column."
+ "Print VALUE, centered using dashes.
+Centers within the span that starts in the current column and continues
+until the next nonblank column."
(ses-center-span value ?- printer))
(defun ses-tildefill-span (value &optional printer)
- "Print VALUE, centered using tildes within the span that starts in the
-current column and continues until the next nonblank column."
+ "Print VALUE, centered using tildes.
+Centers within the span that starts in the current column and continues
+until the next nonblank column."
(ses-center-span value ?~ printer))
(defun ses-prin1 (value)
diff --git a/lisp/shell.el b/lisp/shell.el
index 565ededa1ef..a9990f5d551 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -98,6 +98,7 @@
(require 'comint)
(require 'pcomplete)
(eval-when-compile (require 'files-x)) ;with-connection-local-variables
+(require 'subr-x)
;;; Customization and Buffer Variables
@@ -570,7 +571,14 @@ the initialization of the input ring history, and history expansion.
Variables `comint-output-filter-functions', a hook, and
`comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output'
control whether input and output cause the window to scroll to the end of the
-buffer."
+buffer.
+
+By default, shell mode does nothing special when it receives a
+\"bell\" character (C-g or ^G). If you
+ (add-hook 'comint-output-filter-functions 'shell-filter-ring-bell nil t)
+from `shell-mode-hook', Emacs will call the `ding' function
+whenever it receives the bell character in output from a
+command."
:interactive nil
(setq comint-prompt-regexp shell-prompt-pattern)
(shell-completion-vars)
@@ -681,6 +689,13 @@ This function can be put on `comint-preoutput-filter-functions'."
(replace-regexp-in-string "[\C-a\C-b]" "" string t t)
string))
+(defun shell-filter-ring-bell (string)
+ "Call `ding' if STRING contains a \"^G\" character.
+This function can be put on `comint-output-filter-functions'."
+ (when (string-search "\a" string)
+ (ding))
+ string)
+
(defun shell-write-history-on-exit (process event)
"Called when the shell process is stopped.
diff --git a/lisp/simple.el b/lisp/simple.el
index accc119e2b3..2481d22ad13 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2357,6 +2357,38 @@ maps."
(with-suppressed-warnings ((interactive-only execute-extended-command))
(execute-extended-command prefixarg command-name typed)))
+(cl-defgeneric function-documentation (function)
+ "Extract the raw docstring info from FUNCTION.
+FUNCTION is expected to be a function value rather than, say, a mere symbol.
+This is intended to be specialized via `cl-defmethod' but not called directly:
+if you need a function's documentation use `documentation' which will call this
+function as needed."
+ (let ((docstring-p (lambda (doc)
+ ;; A docstring can be either a string or a reference
+ ;; into either the `etc/DOC' or a `.elc' file.
+ (or (stringp doc)
+ (fixnump doc) (fixnump (cdr-safe doc))))))
+ (pcase function
+ ((pred byte-code-function-p)
+ (when (> (length function) 4)
+ (let ((doc (aref function 4)))
+ (when (funcall docstring-p doc) doc))))
+ ((or (pred stringp) (pred vectorp)) "Keyboard macro.")
+ (`(keymap . ,_)
+ "Prefix command (definition is a keymap associating keystrokes with commands).")
+ ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body)
+ `(autoload ,_file . ,body))
+ (let ((doc (car body)))
+ (when (and (funcall docstring-p doc)
+ ;; Handle a doc reference--but these never come last
+ ;; in the function body, so reject them if they are last.
+ (or (cdr body) (eq 'autoload (car-safe function))))
+ doc)))
+ (_ (signal 'invalid-function (list function))))))
+
+(cl-defmethod function-documentation ((function accessor))
+ (oclosure--accessor-docstring function)) ;; FIXME: η-reduce!
+
(defun command-execute (cmd &optional record-flag keys special)
;; BEWARE: Called directly from the C code.
"Execute CMD as an editor command.
@@ -2840,6 +2872,7 @@ Intended to be added to `minibuffer-setup-hook'."
#'minibuffer-history-isearch-wrap)
(setq-local isearch-push-state-function
#'minibuffer-history-isearch-push-state)
+ (setq-local isearch-lazy-count nil)
(add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t))
(defun minibuffer-history-isearch-end ()
@@ -3890,7 +3923,10 @@ to the end of the list of defaults just after the default value."
(defvar minibuffer-local-shell-command-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
- (define-key map "\t" 'completion-at-point)
+ (define-key map "\t" #'completion-at-point)
+ (define-key map [M-up] #'minibuffer-previous-completion)
+ (define-key map [M-down] #'minibuffer-next-completion)
+ (define-key map [?\M-\r] #'minibuffer-choose-completion)
map)
"Keymap used for completing shell commands in minibuffer.")
@@ -6482,27 +6518,38 @@ An example is a rectangular region handled as a list of
separate contiguous regions for each line."
(cdr (region-bounds)))
+(defun redisplay--unhighlight-overlay-function (rol)
+ "If ROL is an overlay, call `delete-overlay'."
+ (when (overlayp rol) (delete-overlay rol)))
+
(defvar redisplay-unhighlight-region-function
- (lambda (rol) (when (overlayp rol) (delete-overlay rol))))
+ #'redisplay--unhighlight-overlay-function
+ "Function to remove the region-highlight overlay.")
+
+(defun redisplay--highlight-overlay-function (start end window rol &optional face)
+ "Update the overlay ROL in WINDOW with FACE in range START-END."
+ (unless face (setq face 'region))
+ (if (not (overlayp rol))
+ (let ((nrol (make-overlay start end)))
+ (funcall redisplay-unhighlight-region-function rol)
+ (overlay-put nrol 'window window)
+ (overlay-put nrol 'face face)
+ ;; Normal priority so that a large region doesn't hide all the
+ ;; overlays within it, but high secondary priority so that if it
+ ;; ends/starts in the middle of a small overlay, that small overlay
+ ;; won't hide the region's boundaries.
+ (overlay-put nrol 'priority '(nil . 100))
+ nrol)
+ (unless (eq (overlay-get rol 'face) face)
+ (overlay-put rol 'face face))
+ (unless (and (eq (overlay-buffer rol) (current-buffer))
+ (eq (overlay-start rol) start)
+ (eq (overlay-end rol) end))
+ (move-overlay rol start end (current-buffer)))
+ rol))
(defvar redisplay-highlight-region-function
- (lambda (start end window rol)
- (if (not (overlayp rol))
- (let ((nrol (make-overlay start end)))
- (funcall redisplay-unhighlight-region-function rol)
- (overlay-put nrol 'window window)
- (overlay-put nrol 'face 'region)
- ;; Normal priority so that a large region doesn't hide all the
- ;; overlays within it, but high secondary priority so that if it
- ;; ends/starts in the middle of a small overlay, that small overlay
- ;; won't hide the region's boundaries.
- (overlay-put nrol 'priority '(nil . 100))
- nrol)
- (unless (and (eq (overlay-buffer rol) (current-buffer))
- (eq (overlay-start rol) start)
- (eq (overlay-end rol) end))
- (move-overlay rol start end (current-buffer)))
- rol))
+ #'redisplay--highlight-overlay-function
"Function to move the region-highlight overlay.
This function is called with four parameters, START, END, WINDOW
and OVERLAY. If OVERLAY is nil, a new overlay is created. In
@@ -6527,8 +6574,33 @@ The overlay is returned by the function.")
(funcall redisplay-highlight-region-function
start end window rol)))
(unless (equal new rol)
- (set-window-parameter window 'internal-region-overlay
- new))))))
+ (set-window-parameter window 'internal-region-overlay new))))))
+
+(defcustom cursor-face-highlight-nonselected-window nil
+ "Non-nil means highlight text with `cursor-face' even in nonselected windows.
+This variable is similar to `highlight-nonselected-windows'."
+ :local t
+ :type 'boolean
+ :version "29.1")
+
+(defun redisplay--update-cursor-face-highlight (window)
+ "Highlights the overlay used to highlight text with cursor-face."
+ (let ((rol (window-parameter window 'internal-cursor-face-overlay)))
+ (if-let* (((or cursor-face-highlight-nonselected-window
+ (eq window (selected-window))
+ (and (window-minibuffer-p)
+ (eq window (minibuffer-selected-window)))))
+ (pt (window-point window))
+ (cursor-face (get-text-property pt 'cursor-face)))
+ (let* ((start (previous-single-property-change
+ (1+ pt) 'cursor-face nil (point-min)))
+ (end (next-single-property-change
+ pt 'cursor-face nil (point-max)))
+ (new (redisplay--highlight-overlay-function
+ start end window rol cursor-face)))
+ (unless (equal new rol)
+ (set-window-parameter window 'internal-cursor-face-overlay new)))
+ (redisplay--unhighlight-overlay-function rol))))
(defvar pre-redisplay-functions (list #'redisplay--update-region-highlight)
"Hook run just before redisplay.
@@ -6536,6 +6608,15 @@ It is called in each window that is to be redisplayed. It takes one argument,
which is the window that will be redisplayed. When run, the `current-buffer'
is set to the buffer displayed in that window.")
+(define-minor-mode cursor-face-highlight-mode
+ "When enabled, respect the cursor-face property."
+ :global nil
+ (if cursor-face-highlight-mode
+ (add-hook 'pre-redisplay-functions
+ #'redisplay--update-cursor-face-highlight nil t)
+ (remove-hook 'pre-redisplay-functions
+ #'redisplay--update-cursor-face-highlight t)))
+
(defun redisplay--pre-redisplay-functions (windows)
(with-demoted-errors "redisplay--pre-redisplay-functions: %S"
(if (null windows)
@@ -6545,9 +6626,11 @@ is set to the buffer displayed in that window.")
(with-current-buffer (window-buffer win)
(run-hook-with-args 'pre-redisplay-functions win))))))
-(add-function :before pre-redisplay-function
- #'redisplay--pre-redisplay-functions)
-
+(when (eq pre-redisplay-function #'ignore)
+ ;; Override the default set in the C code.
+ ;; This is not done using `add-function' so as to loosen the bootstrap
+ ;; dependencies.
+ (setq pre-redisplay-function #'redisplay--pre-redisplay-functions))
(defvar-local mark-ring nil
"The list of former marks of the current buffer, most recent first.")
@@ -9071,6 +9154,16 @@ Its value is a list of the form (START END) where START is the place
where the completion should be inserted and END (if non-nil) is the end
of the text to replace. If END is nil, point is used instead.")
+(defvar completion-base-affixes nil
+ "Base context of the text corresponding to the shown completions.
+This variable is used in the *Completions* buffer.
+Its value is a list of the form (PREFIX SUFFIX) where PREFIX is the text
+before the place where completion should be inserted, and SUFFIX is the text
+after the completion.")
+
+(defvar completion-use-base-affixes nil
+ "Non-nil means to restore original prefix and suffix in the minibuffer.")
+
(defvar completion-list-insert-choice-function #'completion--replace
"Function to use to insert the text chosen in *Completions*.
Called with three arguments (BEG END TEXT), it should replace the text
@@ -9096,6 +9189,22 @@ This affects the commands `next-completion' and
:version "29.1"
:group 'completion)
+(defcustom completion-auto-select nil
+ "Non-nil means to automatically select the *Completions* buffer.
+When the value is t, pressing TAB will switch to the completion list
+buffer when Emacs pops up a window showing that buffer.
+If the value is `second-tab', then the first TAB will pop up the
+window shwoing the completions list buffer, and the next TAB will
+switch to that window.
+See `completion-auto-help' for controlling when the window showing
+the completions is popped up and down."
+ :type '(choice (const :tag "Don't auto-select completions window" nil)
+ (const :tag "Select completions window on first TAB" t)
+ (const :tag
+ "Select completions window on second TAB" second-tab))
+ :version "29.1"
+ :group 'completion)
+
(defun previous-completion (n)
"Move to the previous item in the completion list.
With prefix argument N, move back N items (negative N means move
@@ -9108,60 +9217,82 @@ forward)."
With prefix argument N, move N items (negative N means move
backward)."
(interactive "p")
- (let ((beg (point-min)) (end (point-max)))
+ (let ((prev (previous-single-property-change (point) 'mouse-face)))
+ (goto-char (cond
+ ((not prev)
+ (1- (next-single-property-change (point) 'mouse-face)))
+ ((/= prev (point))
+ (point))
+ (t prev))))
+
+ (let ((beg (point-min))
+ (end (point-max))
+ (tabcommand (member (this-command-keys) '("\t" [backtab])))
+ prop)
(catch 'bound
(while (> n 0)
;; If in a completion, move to the end of it.
(when (get-text-property (point) 'mouse-face)
(goto-char (next-single-property-change (point) 'mouse-face nil end)))
;; If at the last completion option, wrap or skip to the
- ;; minibuffer, if requested.
- (when (and completion-wrap-movement (eobp))
- (if (and (member (this-command-keys) '("\t" [backtab]))
- completion-auto-select)
+ ;; minibuffer, if requested. We can't use (eobp) because some
+ ;; extra text may be after the last candidate: ex: when
+ ;; completion-detailed
+ (setq prop (next-single-property-change (point) 'mouse-face nil end))
+ (when (and completion-wrap-movement (eq end prop))
+ (if (and completion-auto-select tabcommand)
(throw 'bound nil)
(goto-char (point-min))))
;; Move to start of next one.
(unless (get-text-property (point) 'mouse-face)
(goto-char (next-single-property-change (point) 'mouse-face nil end)))
(setq n (1- n)))
- (while (< n 0)
- (let ((prop (get-text-property (1- (point)) 'mouse-face)))
- ;; If in a completion, move to the start of it.
- (when (and prop (eq prop (get-text-property (point) 'mouse-face)))
- (goto-char (previous-single-property-change
- (point) 'mouse-face nil beg)))
- ;; Move to end of the previous completion.
- (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face))
- (goto-char (previous-single-property-change
- (point) 'mouse-face nil beg)))
- ;; If at the first completion option, wrap or skip to the
- ;; minibuffer, if requested.
- (when (and completion-wrap-movement (bobp))
- (if (and (member (this-command-keys) '("\t" [backtab]))
- completion-auto-select)
- (progn
- (goto-char (next-single-property-change (point) 'mouse-face nil end))
- (throw 'bound nil))
- (goto-char (point-max))))
- ;; Move to the start of that one.
+
+ (while (and (< n 0) (not (bobp)))
+ (setq prop (get-text-property (1- (point)) 'mouse-face))
+ ;; If in a completion, move to the start of it.
+ (when (and prop (eq prop (get-text-property (point) 'mouse-face)))
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil beg)))
+ ;; Move to end of the previous completion.
+ (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face))
(goto-char (previous-single-property-change
- (point) 'mouse-face nil beg))
- (setq n (1+ n)))))
+ (point) 'mouse-face nil beg)))
+ ;; If at the first completion option, wrap or skip to the
+ ;; minibuffer, if requested.
+ (setq prop (previous-single-property-change (point) 'mouse-face nil beg))
+ (when (and completion-wrap-movement (eq beg prop))
+ (if (and completion-auto-select tabcommand)
+ (progn
+ (goto-char (next-single-property-change (point) 'mouse-face nil end))
+ (throw 'bound nil))
+ (goto-char (point-max))))
+ ;; Move to the start of that one.
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil beg))
+ (setq n (1+ n))))
(when (/= 0 n)
(switch-to-minibuffer))))
-(defun choose-completion (&optional event)
+(defun choose-completion (&optional event no-exit no-quit)
"Choose the completion at point.
-If EVENT, use EVENT's position to determine the starting position."
- (interactive (list last-nonmenu-event))
+If EVENT, use EVENT's position to determine the starting position.
+With prefix argument NO-EXIT, insert the completion at point to the
+minibuffer, but don't exit the minibuffer. When the prefix argument
+is not provided, then whether to exit the minibuffer depends on the value
+of `completion-no-auto-exit'.
+If NO-QUIT is non-nil, insert the completion at point to the
+minibuffer, but don't quit the completions window."
+ (interactive (list last-nonmenu-event current-prefix-arg))
;; In case this is run via the mouse, give temporary modes such as
;; isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
(with-current-buffer (window-buffer (posn-window (event-start event)))
(let ((buffer completion-reference-buffer)
(base-position completion-base-position)
+ (base-affixes completion-base-affixes)
(insert-function completion-list-insert-choice-function)
+ (completion-no-auto-exit (if no-exit t completion-no-auto-exit))
(choice
(save-excursion
(goto-char (posn-point (event-start event)))
@@ -9179,12 +9310,14 @@ If EVENT, use EVENT's position to determine the starting position."
(unless (buffer-live-p buffer)
(error "Destination buffer is dead"))
- (quit-window nil (posn-window (event-start event)))
+ (unless no-quit
+ (quit-window nil (posn-window (event-start event))))
(with-current-buffer buffer
(choose-completion-string
choice buffer
- (or base-position
+ (or (and completion-use-base-affixes base-affixes)
+ base-position
;; If all else fails, just guess.
(list (choose-completion-guess-base-position choice)))
insert-function)))))
@@ -9317,12 +9450,6 @@ Called from `temp-buffer-show-hook'."
:version "22.1"
:group 'completion)
-(defcustom completion-auto-select nil
- "Non-nil means to automatically select the *Completions* buffer."
- :type 'boolean
- :version "29.1"
- :group 'completion)
-
;; This function goes in completion-setup-hook, so that it is called
;; after the text of the completion list buffer is written.
(defun completion-setup-function ()
@@ -9344,14 +9471,19 @@ Called from `temp-buffer-show-hook'."
(buffer-substring (minibuffer-prompt-end) (point)))))))
(with-current-buffer standard-output
(let ((base-position completion-base-position)
+ (base-affixes completion-base-affixes)
(insert-fun completion-list-insert-choice-function))
(completion-list-mode)
(setq-local completion-base-position base-position)
+ (setq-local completion-base-affixes base-affixes)
(setq-local completion-list-insert-choice-function insert-fun))
(setq-local completion-reference-buffer mainbuf)
(if base-dir (setq default-directory base-dir))
(when completion-tab-width
(setq tab-width completion-tab-width))
+ ;; Maybe enable cursor completions-highlight.
+ (when completions-highlight-face
+ (cursor-face-highlight-mode 1))
;; Maybe insert help string.
(when completion-show-help
(goto-char (point-min))
@@ -9360,7 +9492,7 @@ Called from `temp-buffer-show-hook'."
(insert (substitute-command-keys
"In this buffer, type \\[choose-completion] to \
select the completion near point.\n\n")))))
- (when completion-auto-select
+ (when (eq completion-auto-select t)
(switch-to-completions)))
(add-hook 'completion-setup-hook #'completion-setup-function)
@@ -9368,22 +9500,18 @@ select the completion near point.\n\n")))))
(defun switch-to-completions ()
"Select the completion list window."
(interactive)
- (let ((window (or (get-buffer-window "*Completions*" 0)
- ;; Make sure we have a completions window.
- (progn (minibuffer-completion-help)
- (get-buffer-window "*Completions*" 0)))))
- (when window
- (select-window window)
+ (when-let ((window (or (get-buffer-window "*Completions*" 0)
+ ;; Make sure we have a completions window.
+ (progn (minibuffer-completion-help)
+ (get-buffer-window "*Completions*" 0)))))
+ (select-window window)
+ (when (bobp)
(cond
((and (memq this-command '(completion-at-point minibuffer-complete))
- (equal (this-command-keys) [backtab])
- (bobp))
+ (equal (this-command-keys) [backtab]))
(goto-char (point-max))
(previous-completion 1))
- ;; In the new buffer, go to the first completion.
- ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'.
- ((bobp)
- (next-completion 1))))))
+ (t (next-completion 1))))))
(defun read-expression-switch-to-completions ()
"Select the completion list window while reading an expression."
@@ -9909,7 +10037,7 @@ warning using STRING as the message.")
(and list
(boundp symbol)
(or (eq symbol t)
- (and (stringp (setq symbol (eval symbol)))
+ (and (stringp (setq symbol (symbol-value symbol)))
(string-match-p (nth 2 list) symbol)))
(display-warning package (nth 3 list) :warning)))
(error nil)))
diff --git a/lisp/subr.el b/lisp/subr.el
index 2321765f953..e7d5d36461c 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2719,7 +2719,8 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'."
(defun memory-limit ()
"Return an estimate of Emacs virtual memory usage, divided by 1024."
- (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))
+ (let ((default-directory temporary-file-directory))
+ (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)))
;;;; Input and display facilities.
@@ -3118,7 +3119,7 @@ If there is a natural number at point, use it as default."
(make-hash-table :test 'equal))
(defun read-char-from-minibuffer-insert-char ()
- "Insert the character you type in the minibuffer and exit.
+ "Insert the character you type into the minibuffer and exit minibuffer.
Discard all previous input before inserting and exiting the minibuffer."
(interactive)
(when (minibufferp)
@@ -3127,9 +3128,11 @@ Discard all previous input before inserting and exiting the minibuffer."
(exit-minibuffer)))
(defun read-char-from-minibuffer-insert-other ()
- "Handle inserting of a character other than allowed.
-Display an error on trying to insert a disallowed character.
-Also discard all previous input in the minibuffer."
+ "Reject a disallowed character typed into the minibuffer.
+This command is intended to be bound to keys that users are not
+allowed to type into the minibuffer. When the user types any
+such key, this command discard all minibuffer input and displays
+an error message."
(interactive)
(when (minibufferp)
(delete-minibuffer-contents)
@@ -3758,14 +3761,18 @@ Note: :data and :device are currently not supported on Windows."
(declare-function w32-shell-dos-semantics "w32-fns" nil)
-(defun shell-quote-argument (argument)
+(defun shell-quote-argument (argument &optional posix)
"Quote ARGUMENT for passing as argument to an inferior shell.
This function is designed to work with the syntax of your system's
standard shell, and might produce incorrect results with unusual shells.
-See Info node `(elisp)Security Considerations'."
- (cond
- ((eq system-type 'ms-dos)
+See Info node `(elisp)Security Considerations'.
+
+If the optional POSIX argument is non-nil, ARGUMENT is quoted
+according to POSIX shell quoting rules, regardless of the
+system's shell."
+(cond
+ ((and (not posix) (eq system-type 'ms-dos))
;; Quote using double quotes, but escape any existing quotes in
;; the argument with backslashes.
(let ((result "")
@@ -3780,7 +3787,7 @@ See Info node `(elisp)Security Considerations'."
start (1+ end))))
(concat "\"" result (substring argument start) "\"")))
- ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics))
+ ((and (not posix) (eq system-type 'windows-nt) (w32-shell-dos-semantics))
;; First, quote argument so that CommandLineToArgvW will
;; understand it. See
@@ -6613,4 +6620,35 @@ OBJECT if it is readable."
(forward-line 1)
(point))))
+(defun ensure-empty-lines (&optional lines)
+ "Ensure that there are LINES number of empty lines before point.
+If LINES is nil or omitted, ensure that there is a single empty
+line before point.
+
+If called interactively, LINES is given by the prefix argument.
+
+If there are more than LINES empty lines before point, the number
+of empty lines is reduced to LINES.
+
+If point is not at the beginning of a line, a newline character
+is inserted before adjusting the number of empty lines."
+ (interactive "p")
+ (unless (bolp)
+ (insert "\n"))
+ (let ((lines (or lines 1))
+ (start (save-excursion
+ (if (re-search-backward "[^\n]" nil t)
+ (+ (point) 2)
+ (point-min)))))
+ (cond
+ ((> (- (point) start) lines)
+ (delete-region (point) (- (point) (- (point) start lines))))
+ ((< (- (point) start) lines)
+ (insert (make-string (- lines (- (point) start)) ?\n))))))
+
+(defun string-lines (string &optional omit-nulls)
+ "Split STRING into a list of lines.
+If OMIT-NULLS, empty lines will be removed from the results."
+ (split-string string "\n" omit-nulls))
+
;;; subr.el ends here
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 245a55a671f..c4d450fe2a5 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -1384,7 +1384,8 @@ After the tab is created, the hooks in
(split-window) (delete-window))))
(let ((buffer
- (if (functionp tab-bar-new-tab-choice)
+ (if (and (functionp tab-bar-new-tab-choice)
+ (not (memq tab-bar-new-tab-choice '(clone window))))
(funcall tab-bar-new-tab-choice)
(if (stringp tab-bar-new-tab-choice)
(or (get-buffer tab-bar-new-tab-choice)
@@ -1658,9 +1659,10 @@ happens interactively)."
(setq index (max 0 (min index (length tabs))))
(cl-pushnew tab (nthcdr index tabs))
(when (eq index 0)
- ;; pushnew handles the head of tabs but not frame-parameter
+ ;; `pushnew' handles the head of tabs but not frame-parameter
(tab-bar-tabs-set tabs))
- (tab-bar-select-tab (1+ index))))
+ (tab-bar-select-tab (1+ index)))
+ (tab-bar--update-tab-bar-lines))
(message "No more closed tabs to undo")))
diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index 83f70edd2c3..955947fe6a2 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -44,31 +44,84 @@
(defvar x-command-line-resources)
(defvar haiku-initialized)
+(defvar haiku-signal-invalid-refs)
+(defvar haiku-drag-track-function)
(defvar haiku-dnd-selection-value nil
"The local value of the special `XdndSelection' selection.")
-(defvar haiku-dnd-selection-converters '((STRING . haiku-dnd-convert-string))
+(defvar haiku-dnd-selection-converters '((STRING . haiku-dnd-convert-string)
+ (text/uri-list . haiku-dnd-convert-uri-list))
"Alist of X selection types to functions that act as selection converters.
The functions should accept a single argument VALUE, describing
the value of the drag-and-drop selection, and return a list of
two elements TYPE and DATA, where TYPE is a string containing the
MIME type of DATA, and DATA is a unibyte string, or nil if the
-data could not be converted.")
+data could not be converted.
+
+DATA can optionally have a text property `type', which specifies
+the type of DATA inside the system message (see the doc string of
+`haiku-drag-message' for more details).")
+
+(defvar haiku-normal-selection-encoders '(haiku-select-encode-xstring
+ haiku-select-encode-utf-8-string)
+ "List of functions which act as selection encoders.
+These functions accept two arguments SELECTION and VALUE, and
+return an association appropriate for a serialized system
+message (or nil if VALUE is not applicable to the encoder) that
+will be put into the system selection SELECTION. VALUE is the
+content that is being put into the selection by
+`gui-set-selection'. See the doc string of `haiku-drag-message'
+for more details on the structure of the associations.")
+
+(defun haiku-selection-bounds (value)
+ "Return bounds of selection value VALUE.
+The return value is a list (BEG END BUF) if VALUE is a cons of
+two markers or an overlay. Otherwise, it is nil."
+ (cond ((bufferp value)
+ (with-current-buffer value
+ (when (mark t)
+ (list (mark t) (point) value))))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (when (and (marker-buffer (car value))
+ (buffer-name (marker-buffer (car value)))
+ (eq (marker-buffer (car value))
+ (marker-buffer (cdr value))))
+ (list (marker-position (car value))
+ (marker-position (cdr value))
+ (marker-buffer (car value)))))
+ ((overlayp value)
+ (when (overlay-buffer value)
+ (list (overlay-start value)
+ (overlay-end value)
+ (overlay-buffer value))))))
(defun haiku-dnd-convert-string (value)
"Convert VALUE to a UTF-8 string and appropriate MIME type.
Return a list of the appropriate MIME type, and UTF-8 data of
VALUE as a unibyte string, or nil if VALUE was not a string."
+ (unless (stringp value)
+ (when-let ((bounds (haiku-selection-bounds value)))
+ (setq value (ignore-errors
+ (with-current-buffer (nth 2 bounds)
+ (buffer-substring (nth 0 bounds)
+ (nth 1 bounds)))))))
(when (stringp value)
(list "text/plain" (string-to-unibyte
(encode-coding-string value 'utf-8)))))
+(defun haiku-dnd-convert-uri-list (value)
+ "Convert VALUE to a file system reference if it is a file name."
+ (when (and (stringp value)
+ (file-exists-p value))
+ (list "refs" (propertize (expand-file-name value) 'type 'ref))))
+
(declare-function x-open-connection "haikufns.c")
(declare-function x-handle-args "common-win")
(declare-function haiku-selection-data "haikuselect.c")
(declare-function haiku-selection-put "haikuselect.c")
-(declare-function haiku-selection-targets "haikuselect.c")
(declare-function haiku-selection-owner-p "haikuselect.c")
(declare-function haiku-put-resource "haikufns.c")
(declare-function haiku-drag-message "haikuselect.c")
@@ -112,6 +165,40 @@ If TYPE is nil, return \"text/plain\"."
((symbolp type) (symbol-name type))
(t "text/plain")))
+(defun haiku-selection-targets (clipboard)
+ "Find the types of data available from CLIPBOARD.
+CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or
+`CLIPBOARD'. Return the available types as a list of strings."
+ (mapcar #'car (haiku-selection-data clipboard nil)))
+
+(defun haiku-select-encode-xstring (_selection value)
+ "Convert VALUE to a system message association.
+VALUE will be encoded as Latin-1 (like on X Windows) and stored
+under the type `text/plain;charset=iso-8859-1'."
+ (unless (stringp value)
+ (when-let ((bounds (haiku-selection-bounds value)))
+ (setq value (ignore-errors
+ (with-current-buffer (nth 2 bounds)
+ (buffer-substring (nth 0 bounds)
+ (nth 1 bounds)))))))
+ (when (and (stringp value) (not (string-empty-p value)))
+ (list "text/plain;charset=iso-8859-1" 1296649541
+ (encode-coding-string value 'iso-latin-1))))
+
+(defun haiku-select-encode-utf-8-string (_selection value)
+ "Convert VALUE to a system message association.
+VALUE will be encoded as UTF-8 and stored under the type
+`text/plain'."
+ (unless (stringp value)
+ (when-let ((bounds (haiku-selection-bounds value)))
+ (setq value (ignore-errors
+ (with-current-buffer (nth 2 bounds)
+ (buffer-substring (nth 0 bounds)
+ (nth 1 bounds)))))))
+ (when (and (stringp value) (not (string-empty-p value)))
+ (list "text/plain" 1296649541
+ (encode-coding-string value 'utf-8-unix))))
+
(cl-defmethod gui-backend-get-selection (type data-type
&context (window-system haiku))
(if (eq data-type 'TARGETS)
@@ -125,7 +212,12 @@ If TYPE is nil, return \"text/plain\"."
&context (window-system haiku))
(if (eq type 'XdndSelection)
(setq haiku-dnd-selection-value value)
- (haiku-selection-put type "text/plain" value t)))
+ (let ((message nil))
+ (dolist (encoder haiku-normal-selection-encoders)
+ (let ((result (funcall encoder type value)))
+ (when result
+ (push result message))))
+ (haiku-selection-put type message))))
(cl-defmethod gui-backend-selection-exists-p (selection
&context (window-system haiku))
@@ -149,31 +241,37 @@ If TYPE is nil, return \"text/plain\"."
(file-name-nondirectory default-filename))
(error "x-file-dialog on a tty frame")))
-(defun haiku-dnd-handle-drag-n-drop-event (event)
+(defun haiku-drag-and-drop (event)
"Handle specified drag-n-drop EVENT."
(interactive "e")
(let* ((string (caddr event))
(window (posn-window (event-start event))))
- (cond
- ((assoc "refs" string)
- (with-selected-window window
- (raise-frame)
- (dolist (filename (cddr (assoc "refs" string)))
- (dnd-handle-one-url window 'private
- (concat "file:" filename)))))
- ((assoc "text/plain" string)
- (with-selected-window window
- (raise-frame)
- (dolist (text (cddr (assoc "text/plain" string)))
- (goto-char (posn-point (event-start event)))
- (dnd-insert-text window 'private
- (if (multibyte-string-p text)
- text
- (decode-coding-string text 'undecided))))))
- (t (message "Don't know how to drop any of: %s" (mapcar #'car string))))))
+ (if (eq string 'lambda) ; This means the mouse moved.
+ (dnd-handle-movement (event-start event))
+ (cond
+ ((assoc "refs" string)
+ (with-selected-window window
+ (raise-frame)
+ (dolist (filename (cddr (assoc "refs" string)))
+ (dnd-handle-one-url window 'private
+ (concat "file:" filename)))))
+ ((assoc "text/plain" string)
+ (with-selected-window window
+ (raise-frame)
+ (dolist (text (cddr (assoc "text/plain" string)))
+ (goto-char (posn-point (event-start event)))
+ (dnd-insert-text window 'private
+ (if (multibyte-string-p text)
+ text
+ (decode-coding-string text 'undecided))))))
+ ((not (eq (cdr (assq 'type string))
+ 3003)) ; Type of the placeholder message Emacs uses
+ ; to cancel a drop on C-g.
+ (message "Don't know how to drop any of: %s"
+ (mapcar #'car string)))))))
(define-key special-event-map [drag-n-drop]
- 'haiku-dnd-handle-drag-n-drop-event)
+ 'haiku-drag-and-drop)
(defvaralias 'haiku-use-system-tooltips 'use-system-tooltips)
@@ -183,11 +281,28 @@ This is necessary because on Haiku `use-system-tooltip' doesn't
take effect on menu items until the menu bar is updated again."
(force-mode-line-update t))
-(defun x-begin-drag (targets &optional action frame _return-frame)
+;; Note that `mouse-position' can't return the actual frame the mouse
+;; pointer is under, so this only works for the frame where the drop
+;; started.
+(defun haiku-dnd-drag-handler ()
+ "Handle mouse movement during drag-and-drop."
+ (let ((track-mouse 'drag-source)
+ (mouse-position (mouse-pixel-position)))
+ (when (car mouse-position)
+ (dnd-handle-movement (posn-at-x-y (cadr mouse-position)
+ (cddr mouse-position)
+ (car mouse-position)))
+ (redisplay))))
+
+(setq haiku-drag-track-function #'haiku-dnd-drag-handler)
+
+(defun x-begin-drag (targets &optional action frame _return-frame allow-current-frame)
"SKIP: real doc in xfns.c."
(unless haiku-dnd-selection-value
(error "No local value for XdndSelection"))
- (let ((message nil))
+ (let ((message nil)
+ (mouse-highlight nil)
+ (haiku-signal-invalid-refs nil))
(dolist (target targets)
(let ((selection-converter (cdr (assoc (intern target)
haiku-dnd-selection-converters))))
@@ -199,15 +314,20 @@ take effect on menu items until the menu bar is updated again."
(let ((field (cdr (assoc (car selection-result) message))))
(unless (cadr field)
;; Add B_MIME_TYPE to the message if the type was not
- ;; previously defined.
- (push 1296649541 (alist-get (car selection-result) message
- nil nil #'equal))))
+ ;; previously specified, or the type if it was.
+ (push (or (get-text-property 0 'type
+ (cadr selection-result))
+ 1296649541)
+ (alist-get (car selection-result) message
+ nil nil #'equal))))
(push (cadr selection-result)
(cdr (alist-get (car selection-result) message
nil nil #'equal))))))))
- (prog1 (or action 'XdndActionCopy)
+ (prog1 (or (and (symbolp action)
+ action)
+ 'XdndActionCopy)
(haiku-drag-message (or frame (selected-frame))
- message))))
+ message allow-current-frame))))
(add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher)
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index da6c5adee22..065ca235b40 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -508,25 +508,28 @@ unless the current buffer is a scratch buffer."
Switch to a buffer editing the last file dropped, or insert the
string dropped into the current buffer."
(interactive "e")
- (let* ((window (posn-window (event-start event)))
- (arg (car (cdr (cdr event))))
- (type (car arg))
- (operations (car (cdr arg)))
- (objects (cdr (cdr arg)))
- (string (mapconcat 'identity objects "\n")))
- (set-frame-selected-window nil window)
- (raise-frame)
- (setq window (selected-window))
- (cond ((or (memq 'ns-drag-operation-generic operations)
- (memq 'ns-drag-operation-copy operations))
- ;; Perform the default/copy action.
- (dolist (data objects)
- (dnd-handle-one-url window 'private (if (eq type 'file)
- (concat "file:" data)
- data))))
- (t
- ;; Insert the text as is.
- (dnd-insert-text window 'private string)))))
+ (if (eq (car-safe (cdr-safe (cdr-safe event))) 'lambda)
+ (dnd-handle-movement (event-start event))
+ (let* ((window (posn-window (event-start event)))
+ (arg (car (cdr (cdr event))))
+ (type (car arg))
+ (operations (car (cdr arg)))
+ (objects (cdr (cdr arg)))
+ (string (mapconcat 'identity objects "\n")))
+ (set-frame-selected-window nil window)
+ (raise-frame)
+ (setq window (selected-window))
+ (goto-char (posn-point (event-start event)))
+ (cond ((or (memq 'ns-drag-operation-generic operations)
+ (memq 'ns-drag-operation-copy operations))
+ ;; Perform the default/copy action.
+ (dolist (data objects)
+ (dnd-handle-one-url window 'private (if (eq type 'file)
+ (concat "file:" data)
+ data))))
+ (t
+ ;; Insert the text as is.
+ (dnd-insert-text window 'private string))))))
(global-set-key [drag-n-drop] 'ns-drag-n-drop)
diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el
index 327d51f2759..514267a52d6 100644
--- a/lisp/term/pc-win.el
+++ b/lisp/term/pc-win.el
@@ -246,6 +246,14 @@ Consult the selection. Treat empty strings as if they were unset."
;; if it does not exist, or exists and compares
;; equal with the last text we've put into the
;; Windows clipboard.
+ ;; NOTE: that variable is actually the last text any program
+ ;; (not just Emacs) has put into the windows clipboard (up
+ ;; until the last time Emacs read or set the clipboard), so
+ ;; it's not suitable for checking actual selection
+ ;; ownership. This should not result in a bug for the current
+ ;; uses of gui-backend-selection-owner however, since they
+ ;; don't actually care about selection ownership, but about
+ ;; the selected text having changed.
(cond
((not text) t)
((equal text gui--last-selected-text-clipboard) text)
diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el
index 8e17864284e..5317f6ba01a 100644
--- a/lisp/term/pgtk-win.el
+++ b/lisp/term/pgtk-win.el
@@ -1,4 +1,4 @@
-;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*-
+;;; pgtk-win.el --- parse relevant switches and set up for Pure-GTK -*- lexical-binding: t -*-
;; Copyright (C) 1995, 2001-2020, 2022 Free Software Foundation, Inc.
@@ -23,10 +23,11 @@
;;; Commentary:
;;; Code:
+
(eval-when-compile (require 'cl-lib))
-(or (featurep 'pgtk)
- (error "%s: Loading pgtk-win.el but not compiled for pure Gtk+-3."
- invocation-name))
+(unless (featurep 'pgtk)
+ (error "%s: Loading pgtk-win.el but not compiled with PGTK."
+ invocation-name))
;; Documentation-purposes only: actually loaded in loadup.el.
(require 'term/common-win)
@@ -38,39 +39,14 @@
(require 'fontset)
(require 'dnd)
-(defgroup pgtk nil
- "Pure-GTK specific features."
- :group 'environment)
-
-;;;; Command line argument handling.
-
(defvar x-invocation-args)
-;; Set in term/common-win.el; currently unused by Gtk's x-open-connection.
(defvar x-command-line-resources)
-
-;; pgtkterm.c.
(defvar pgtk-input-file)
-
-(declare-function pgtk-use-im-context "pgtkim.c")
(defvar pgtk-use-im-context-on-new-connection)
-(defun pgtk-handle-nxopen (_switch &optional temp)
- (setq unread-command-events (append unread-command-events
- (if temp '(pgtk-open-temp-file)
- '(pgtk-open-file)))
- pgtk-input-file (append pgtk-input-file (list (pop x-invocation-args)))))
-
-(defun pgtk-handle-nxopentemp (switch)
- (pgtk-handle-nxopen switch t))
-
-(defun pgtk-ignore-1-arg (_switch)
- (setq x-invocation-args (cdr x-invocation-args)))
-
-;;;; File handling.
-
+(declare-function pgtk-use-im-context "pgtkim.c")
(declare-function pgtk-hide-emacs "pgtkfns.c" (on))
-
(defun pgtk-drag-n-drop (event &optional new-frame force-text)
"Edit the files listed in the drag-n-drop EVENT.
Switch to a buffer editing the last file dropped."
@@ -91,7 +67,6 @@ Switch to a buffer editing the last file dropped."
(dnd-insert-text window 'private data)
(dnd-handle-one-url window 'private url-or-string))))
-
(defun pgtk-drag-n-drop-other-frame (event)
"Edit the files listed in the drag-n-drop EVENT, in other frames.
May create new frames, or reuse existing ones. The frame editing
@@ -110,132 +85,12 @@ the last file dropped is selected."
(pgtk-drag-n-drop event t t))
(global-set-key [drag-n-drop] 'pgtk-drag-n-drop)
-(global-set-key [C-drag-n-drop] 'pgtk-drag-n-drop-other-frame)
-(global-set-key [M-drag-n-drop] 'pgtk-drag-n-drop-as-text)
-(global-set-key [C-M-drag-n-drop] 'pgtk-drag-n-drop-as-text-other-frame)
-
-;;;; Frame-related functions.
-
-;; pgtkterm.c
-(defvar pgtk-alternate-modifier)
-(defvar pgtk-right-alternate-modifier)
-(defvar pgtk-right-command-modifier)
-(defvar pgtk-right-control-modifier)
-
-;; You say tomAYto, I say tomAHto..
-(with-no-warnings
- (defvaralias 'pgtk-option-modifier 'pgtk-alternate-modifier)
- (defvaralias 'pgtk-right-option-modifier 'pgtk-right-alternate-modifier))
-
-(defun pgtk-do-hide-emacs ()
- (interactive)
- (pgtk-hide-emacs t))
-
-(declare-function pgtk-hide-others "pgtkfns.c" ())
-
-(defun pgtk-do-hide-others ()
- (interactive)
- (pgtk-hide-others))
-
-(declare-function pgtk-emacs-info-panel "pgtkfns.c" ())
-
-(defun pgtk-do-emacs-info-panel ()
- (interactive)
- (pgtk-emacs-info-panel))
-
-(defun pgtk-next-frame ()
- "Switch to next visible frame."
- (interactive)
- (other-frame 1))
-
-(defun pgtk-prev-frame ()
- "Switch to previous visible frame."
- (interactive)
- (other-frame -1))
-
-;; Frame will be focused anyway, so select it
-;; (if this is not done, mode line is dimmed until first interaction)
-;; FIXME: Sounds like we're working around a bug in the underlying code.
-(add-hook 'after-make-frame-functions 'select-frame)
-
-(defvar tool-bar-mode)
-(declare-function tool-bar-mode "tool-bar" (&optional arg))
-
-;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
-;; see https://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
-(defun pgtk-toggle-toolbar (&optional frame)
- "Switches the tool bar on and off in frame FRAME.
- If FRAME is nil, the change applies to the selected frame."
- (interactive)
- (modify-frame-parameters
- frame (list (cons 'tool-bar-lines
- (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
- 0 1)) ))
- (if (not tool-bar-mode) (tool-bar-mode t)))
-
-
-;;;; Dialog-related functions.
-
-;; Ask user for confirm before printing. Due to Kevin Rodgers.
-(defun pgtk-print-buffer ()
- "Interactive front-end to `print-buffer': asks for user confirmation first."
- (interactive)
- (if (and (called-interactively-p 'interactive)
- (or (listp last-nonmenu-event)
- (and (char-or-string-p (event-basic-type last-command-event))
- (memq 'super (event-modifiers last-command-event)))))
- (let ((last-nonmenu-event (if (listp last-nonmenu-event)
- last-nonmenu-event
- ;; Fake it:
- `(mouse-1 POSITION 1))))
- (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
- (print-buffer)
- (error "Canceled")))
- (print-buffer)))
-
-;;;; Font support.
-
-;; Needed for font listing functions under both backend and normal
-(setq scalable-fonts-allowed t)
-
-;; Default fontset. This is mainly here to show how a fontset
-;; can be set up manually. Ordinarily, fontsets are auto-created whenever
-;; a font is chosen by
-(defvar pgtk-standard-fontset-spec
- ;; Only some code supports this so far, so use uglier XLFD version
- ;; "-pgtk-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
- (mapconcat 'identity
- '("-*-Monospace-*-*-*-*-10-*-*-*-*-*-fontset-standard"
- "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1")
- ",")
- "String of fontset spec of the standard fontset.
-This defines a fontset consisting of the Courier and other fonts.
-See the documentation of `create-fontset-from-fontset-spec' for the format.")
-
-
-;;;; Pasteboard support.
-
-(define-obsolete-function-alias 'pgtk-store-cut-buffer-internal
- 'gui-set-selection "24.1")
-
-
-(defun pgtk-copy-including-secondary ()
- (interactive)
- (call-interactively 'kill-ring-save)
- (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t))))
-
-(defun pgtk-paste-secondary ()
- (interactive)
- (insert (gui-get-selection 'SECONDARY)))
-
(defun pgtk-suspend-error ()
- ;; Don't allow suspending if any of the frames are PGTK frames.
+ "Don't allow suspending if any of the frames are PGTK frames."
(if (memq 'pgtk (mapcar 'window-system (frame-list)))
(error "Cannot suspend Emacs while a PGTK GUI frame exists")))
-
-
(defvar pgtk-initialized nil
"Non-nil if pure-GTK windowing has been initialized.")
@@ -244,31 +99,34 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
(display &optional xrm-string must-succeed))
(declare-function pgtk-set-resource "pgtkfns.c" (owner name value))
-;; Do the actual pure-GTK Windows setup here; the above code just
-;; defines functions and variables that we use now.
+;; Do the actual window system setup here; the above code just defines
+;; functions and variables that we use now.
(cl-defmethod window-system-initialization (&context (window-system pgtk)
&optional display)
- "Initialize Emacs for pure-GTK windowing."
+ "Initialize the PGTK window system.
+WINDOW-SYSTEM is, aptly, `pgtk'.
+DISPLAY is the name of the display Emacs should connect to."
(cl-assert (not pgtk-initialized))
;; PENDING: not needed?
(setq command-line-args (x-handle-args command-line-args))
;; Make sure we have a valid resource name.
- (or (stringp x-resource-name)
+ (when (boundp 'x-resource-name)
+ (unless (stringp x-resource-name)
(let (i)
(setq x-resource-name (copy-sequence invocation-name))
;; Change any . or * characters in x-resource-name to hyphens,
;; so as not to choke when we use it in X resource queries.
(while (setq i (string-match "[.*]" x-resource-name))
- (aset x-resource-name i ?-))))
+ (aset x-resource-name i ?-)))))
;; Setup the default fontset.
(create-default-fontset)
;; Create the standard fontset.
(condition-case err
- (create-fontset-from-fontset-spec pgtk-standard-fontset-spec t)
+ (create-fontset-from-fontset-spec standard-fontset-spec t)
(error (display-warning
'initialization
(format "Creation of the standard fontset failed: %s" err)
@@ -358,14 +216,12 @@ EVENT is a `preedit-text-event'."
(define-key special-event-map [preedit-text] 'pgtk-preedit-text)
-(add-hook 'after-init-hook
- (function
- (lambda ()
- (when (eq window-system 'pgtk)
- (pgtk-use-im-context pgtk-use-im-context-on-new-connection)))))
-
+(defun pgtk-use-im-context-handler ()
+ "Set up input context usage after Emacs initialization."
+ (when (eq window-system 'pgtk)
+ (pgtk-use-im-context pgtk-use-im-context-on-new-connection)))
-;;;
+(add-hook 'after-init-hook #'pgtk-use-im-context-handler)
(defcustom x-gtk-stock-map
(mapcar (lambda (arg)
@@ -511,6 +367,27 @@ This uses `icon-map-list' to map icon file names to stock icon names."
(t
(popup-menu (mouse-menu-bar-map) last-nonmenu-event))))
+(defun pgtk-device-class (name)
+ "Return the device class of NAME.
+Users should not call this function; see `device-class' instead."
+ (cond
+ ((string-match-p "XTEST" name) 'test)
+ ((string= "Virtual core pointer" name) 'core-pointer)
+ ((string= "Virtual core keyboard" name) 'core-keyboard)
+ (t (let ((number (ignore-errors
+ (string-to-number name))))
+ (when number
+ (cl-case number
+ (0 'mouse)
+ (1 'pen)
+ (2 'eraser)
+ (3 'puck)
+ (4 'keyboard)
+ (5 'touchscreen)
+ (6 'touchpad)
+ (7 'trackpoint)
+ (8 'pad)))))))
+
(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips)
(provide 'pgtk-win)
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 4ed01de9aef..7eaa6047763 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -275,6 +275,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
'(gif "libgif-5.dll" "giflib4.dll" "libungif4.dll" "libungif.dll")))
'(svg "librsvg-2-2.dll")
'(webp "libwebp-7.dll" "libwebp.dll")
+ '(webpdemux "libwebpdemux-2.dll" "libwebpdemux.dll")
'(sqlite3 "libsqlite3-0.dll")
'(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll")
'(glib "libglib-2.0-0.dll")
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index 9ae238661e0..4c6fcc904c0 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -85,6 +85,8 @@
(defvar x-selection-timeout)
(defvar x-session-id)
(defvar x-session-previous-id)
+(defvar x-dnd-movement-function)
+(defvar x-dnd-unsupported-drop-function)
(defun x-handle-no-bitmap-icon (_switch)
(setq default-frame-alist (cons '(icon-type) default-frame-alist)))
@@ -1576,6 +1578,53 @@ frames on all displays."
(add-variable-watcher 'x-gtk-use-native-input
#'x-gtk-use-native-input-watcher)
+(defun x-dnd-movement (_frame position)
+ "Handle movement to POSITION during drag-and-drop."
+ (dnd-handle-movement position)
+ (redisplay))
+
+(defun x-device-class (name)
+ "Return the device class of NAME.
+Users should not call this function; see `device-class' instead."
+ (let ((downcased-name (downcase name)))
+ (cond
+ ((string-match-p "XTEST" name) 'test)
+ ((string= "Virtual core pointer" name) 'core-pointer)
+ ((string= "Virtual core keyboard" name) 'core-keyboard)
+ ((string-match-p "eraser" downcased-name) 'eraser)
+ ((string-match-p " pad" downcased-name) 'pad)
+ ((or (or (string-match-p "wacom" downcased-name)
+ (string-match-p "pen" downcased-name))
+ (string-match-p "stylus" downcased-name))
+ 'pen)
+ ((or (string-prefix-p "xwayland-touch:" name)
+ (string-match-p "touchscreen" downcased-name))
+ 'touchscreen)
+ ((or (string-match-p "trackpoint" downcased-name)
+ (string-match-p "stick" downcased-name))
+ 'trackpoint)
+ ((or (string-match-p "mouse" downcased-name)
+ (string-match-p "optical" downcased-name)
+ (string-match-p "pointer" downcased-name))
+ 'mouse)
+ ((string-match-p "cursor" downcased-name) 'puck)
+ ((or (string-match-p "keyboard" downcased-name)
+ ;; One of my cheap keyboards is really named this...
+ (string= name "USB USB Keykoard"))
+ 'keyboard)
+ ((string-match-p "button" downcased-name) 'power-button)
+ ((string-match-p "touchpad" downcased-name) 'touchpad)
+ ((or (string-match-p "midi" downcased-name)
+ (string-match-p "piano" downcased-name))
+ 'piano)
+ ((or (string-match-p "wskbd" downcased-name) ; NetBSD/OpenBSD
+ (and (string-match-p "/dev" downcased-name)
+ (string-match-p "kbd" downcased-name)))
+ 'keyboard))))
+
+(setq x-dnd-movement-function #'x-dnd-movement)
+(setq x-dnd-unsupported-drop-function #'x-dnd-handle-unsupported-drop)
+
(provide 'x-win)
(provide 'term/x-win)
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index ab6a907c52d..d02eca506a8 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -764,6 +764,20 @@ for a new entry."
("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
("url") ("urldate")))
+ ("Conference" "Article in Conference Proceedings" ; same as InProceedings
+ (("author")
+ ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)"))
+ (("booktitle" "Name of the conference proceedings")
+ ("year"))
+ (("editor")
+ ("volume" "Volume of the conference proceedings in the series")
+ ("number" "Number of the conference proceedings in a small series (overwritten by volume)")
+ ("series" "Series in which the conference proceedings appeared")
+ ("pages" "Pages in the conference proceedings")
+ ("month") ("address")
+ ("organization" "Sponsoring organization of the conference")
+ ("publisher" "Publishing company, its location")
+ ("note")))
("Reference" "Single-Volume Work of Reference" ; same as @collection
(("editor") ("title") ("date" nil nil 1) ("year" nil nil -1))
nil
@@ -848,6 +862,15 @@ for a new entry."
(("type" "Type of the PhD thesis")
("address" "Address of the school (if not part of field \"school\") or country")
("month") ("note")))
+ ("MastersThesis" "Master's Thesis"
+ (("author")
+ ("title" "Title of the master's thesis (BibTeX converts it to lowercase)")
+ ("school" "School where the master's thesis was written")
+ ("year"))
+ nil
+ (("type" "Type of the master's thesis (if other than \"Master's thesis\")")
+ ("address" "Address of the school (if not part of field \"school\") or country")
+ ("month") ("note")))
("TechReport" "Technical Report"
(("author")
("title" "Title of the technical report (BibTeX converts it to lowercase)")
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 5f9ccc094af..b3dca5890f1 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -82,7 +82,7 @@ question.
(defun forward-thing (thing &optional n)
"Move forward to the end of the Nth next THING.
THING should be a symbol specifying a type of syntactic entity.
-Possibilities include `symbol', `list', `sexp', `defun',
+Possibilities include `symbol', `list', `sexp', `defun', `number',
`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'."
(let ((forward-op (or (get thing 'forward-op)
@@ -97,7 +97,7 @@ Possibilities include `symbol', `list', `sexp', `defun',
(defun bounds-of-thing-at-point (thing)
"Determine the start and end buffer locations for the THING at point.
THING should be a symbol specifying a type of syntactic entity.
-Possibilities include `symbol', `list', `sexp', `defun',
+Possibilities include `symbol', `list', `sexp', `defun', `number',
`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'.
@@ -732,6 +732,7 @@ Signal an error if the entire string was not used."
"Return the symbol at point, or nil if none is found."
(let ((thing (thing-at-point 'symbol)))
(if thing (intern thing))))
+
;;;###autoload
(defun number-at-point ()
"Return the number at point, or nil if none is found.
@@ -746,7 +747,9 @@ like \"0xBEEF09\" or \"#xBEEF09\", are recognized."
(string-to-number
(buffer-substring (match-beginning 0) (match-end 0))))))
+(put 'number 'forward-op 'forward-word)
(put 'number 'thing-at-point 'number-at-point)
+
;;;###autoload
(defun list-at-point (&optional ignore-comment-or-string)
"Return the Lisp list at point, or nil if none is found.
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index 695fa8a8562..3bf08dd6a58 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -296,7 +296,8 @@ smaller according to whether INCREMENT is 1 or -1."
(defun thumbs-file-size (img)
(let ((i (image-size
- (find-image `((:type ,(image-type-from-file-name img) :file ,img))) t)))
+ (find-image `((:type ,(image-supported-file-p img) :file ,img)))
+ t)))
(concat (number-to-string (round (car i))) "x"
(number-to-string (round (cdr i))))))
@@ -399,7 +400,7 @@ and SAME-WINDOW to show thumbs in the same window."
thumbs-image-num (or num 0))
(delete-region (point-min)(point-max))
(save-excursion
- (thumbs-insert-image img (image-type-from-file-name img) 0)))))
+ (thumbs-insert-image img (image-supported-file-p img) 0)))))
(defun thumbs-find-image-at-point (&optional img otherwin)
"Display image IMG for thumbnail at point.
@@ -533,7 +534,7 @@ Open another window."
" - " (number-to-string num)))
(let ((inhibit-read-only t))
(erase-buffer)
- (thumbs-insert-image img (image-type-from-file-name img) 0)
+ (thumbs-insert-image img (image-supported-file-p img) 0)
(goto-char (point-min))))
(setq thumbs-image-num num
thumbs-current-image-filename img))))
@@ -765,7 +766,7 @@ ACTION and ARG should be a valid convert command."
(define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot)
(define-obsolete-function-alias 'thumbs-image-type
- #'image-type-from-file-name "29.1")
+ #'image-supported-file-p "29.1")
(provide 'thumbs)
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 511cc89778d..5c13c7fc389 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -2634,42 +2634,55 @@ fixed, visit it in a buffer."
(binary (concat
"Binary files " file4
" and " file5 " \\(?7:differ\\)\n"))
- (horb (concat "\\(?:" header "\\|" binary "\\)")))
+ (horb (concat "\\(?:" header "\\|" binary "\\)?")))
(concat "diff.*?\\(?: a/\\(.*?\\) b/\\(.*\\)\\)?\n"
- "\\(?:\\(?:old\\|new\\) mode .*\n\\)*"
"\\(?:"
;; For new/deleted files, there might be no
;; header (and no hunk) if the file is/was empty.
- "\\(?3:new\\(?6:\\)\\|deleted\\) file.*\n"
- index "\\(?:" horb "\\)?"
- ;; Normal case.
- "\\|" index horb "\\)")))))
+ "\\(?3:new\\(?6:\\)\\|deleted\\) file mode \\(?10:[0-7]\\{6\\}\\)\n"
+ index horb
+ ;; Normal case. There might be no header
+ ;; (and no hunk) if only the file mode
+ ;; changed.
+ "\\|"
+ "\\(?:old mode \\(?8:[0-7]\\{6\\}\\)\n\\)?"
+ "\\(?:new mode \\(?9:[0-7]\\{6\\}\\)\n\\)?"
+ index horb "\\)")))))
;; The file names can be extracted either from the `diff' line
;; or from the two header lines. Prefer the header line info if
;; available since the `diff' line is ambiguous in case the
;; file names include " b/" or " a/".
;; FIXME: This prettification throws away all the information
- ;; about file modes (and the index hashes).
+ ;; about the index hashes.
(let ((oldfile (or (match-string 4) (match-string 1)))
(newfile (or (match-string 5) (match-string 2)))
(kind (if (match-beginning 7) " BINARY"
- (unless (or (match-beginning 4) (match-beginning 5))
- " empty"))))
+ (unless (or (match-beginning 4)
+ (match-beginning 5)
+ (not (match-beginning 3)))
+ " empty")))
+ (filemode
+ (cond
+ ((match-beginning 10)
+ (concat " file with mode " (match-string 10) " "))
+ ((and (match-beginning 8) (match-beginning 9))
+ (concat " file (mode changed from "
+ (match-string 8) " to " (match-string 9) ") "))
+ (t " file "))))
(add-text-properties
(match-beginning 0) (1- (match-end 0))
(list 'display
(propertize
(cond
((match-beginning 3)
- (concat (capitalize (match-string 3)) kind " file"
- " "
+ (concat (capitalize (match-string 3)) kind filemode
(if (match-beginning 6) newfile oldfile)))
- ((null (match-string 4))
- (concat "New" kind " file " newfile))
+ ((and (null (match-string 4)) (match-string 5))
+ (concat "New " kind filemode newfile))
((null (match-string 2))
- (concat "Deleted" kind " file " oldfile))
+ (concat "Deleted" kind filemode oldfile))
(t
- (concat "Modified" kind " file " oldfile)))
+ (concat "Modified" kind filemode oldfile)))
'face '(diff-file-header diff-header))
'font-lock-multiline t))))))
nil)
diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el
index 4abcf6c15a7..926993eebb7 100644
--- a/lisp/vc/diff.el
+++ b/lisp/vc/diff.el
@@ -52,6 +52,12 @@ set (`vc-git-diff-switches' for git, for instance), and
"The command to use to run diff."
:type 'string)
+(defcustom diff-entire-buffers t
+ "If non-nil, diff the entire buffers, not just the visible part.
+If nil, only use the narrowed-to parts of the buffers."
+ :type 'boolean
+ :version "29.1")
+
;; prompt if prefix arg present
(defun diff-switches ()
(if current-prefix-arg
@@ -119,7 +125,9 @@ temporary file with the buffer's contents."
(if (bufferp file-or-buf)
(with-current-buffer file-or-buf
(let ((tempfile (make-temp-file "buffer-content-")))
- (write-region nil nil tempfile nil 'nomessage)
+ (if diff-entire-buffers
+ (write-region nil nil tempfile nil 'nomessage)
+ (write-region (point-min) (point-max) tempfile nil 'nomessage))
tempfile))
(file-local-copy file-or-buf)))
@@ -274,7 +282,9 @@ interactively for diff switches. Otherwise, the switches
specified in the variable `diff-switches' are passed to the
diff command.
-OLD and NEW may each be a buffer or a buffer name."
+OLD and NEW may each be a buffer or a buffer name.
+
+Also see the `diff-entire-buffers' variable."
(interactive
(let ((newb (read-buffer "Diff new buffer" (current-buffer) t))
(oldb (read-buffer "Diff original buffer"
diff --git a/lisp/wdired.el b/lisp/wdired.el
index ab3b91bbe55..d2a6bad0f28 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -155,6 +155,11 @@ nonexistent directory will fail."
:version "26.1"
:type 'boolean)
+(defcustom wdired-search-replace-filenames t
+ "Non-nil to search and replace in file names only."
+ :version "29.1"
+ :type 'boolean)
+
(defvar-keymap wdired-mode-map
:doc "Keymap used in `wdired-mode'."
"C-x C-s" #'wdired-finish-edit
@@ -217,6 +222,7 @@ symbolic link targets, and filenames permission."
(error "This mode can be enabled only by `wdired-change-to-wdired-mode'"))
(put 'wdired-mode 'mode-class 'special)
+(declare-function dired-isearch-search-filenames "dired-aux")
;;;###autoload
(defun wdired-change-to-wdired-mode ()
@@ -237,9 +243,16 @@ See `wdired-mode'."
(dired-remember-marks (point-min) (point-max)))
(setq-local wdired--old-point (point))
(wdired--set-permission-bounds)
- (setq-local query-replace-skip-read-only t)
- (add-function :after-while (local 'isearch-filter-predicate)
- #'wdired-isearch-filter-read-only)
+ (when wdired-search-replace-filenames
+ (add-function :around (local 'isearch-search-fun-function)
+ #'dired-isearch-search-filenames
+ '((isearch-message-prefix . "filename ")))
+ (setq-local replace-search-function
+ (setq-local replace-re-search-function
+ (funcall isearch-search-fun-function)))
+ ;; Original dired hook removes dired-isearch-search-filenames that
+ ;; is needed outside isearch for lazy-highlighting in query-replace.
+ (remove-hook 'isearch-mode-hook #'dired-isearch-filenames-setup t))
(use-local-map wdired-mode-map)
(force-mode-line-update)
(setq buffer-read-only nil)
@@ -319,11 +332,6 @@ or \\[wdired-abort-changes] to abort changes")))
;; Is this good enough? Assumes no extra white lines from dired.
(put-text-property (1- (point-max)) (point-max) 'read-only t)))))))
-(defun wdired-isearch-filter-read-only (beg end)
- "Skip matches that have a read-only property."
- (not (text-property-not-all (min beg end) (max beg end)
- 'read-only nil)))
-
;; Protect the buffer so only the filenames can be changed, and put
;; properties so filenames (old and new) can be easily found.
(defun wdired--preprocess-files ()
@@ -438,8 +446,13 @@ non-nil means return old filename."
(remove-text-properties
(point-min) (point-max)
'(front-sticky nil rear-nonsticky nil read-only nil keymap nil)))
- (remove-function (local 'isearch-filter-predicate)
- #'wdired-isearch-filter-read-only)
+ (when wdired-search-replace-filenames
+ (remove-function (local 'isearch-search-fun-function)
+ #'dired-isearch-search-filenames)
+ (kill-local-variable 'replace-search-function)
+ (kill-local-variable 'replace-re-search-function)
+ ;; Restore dired hook
+ (add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t))
(use-local-map dired-mode-map)
(force-mode-line-update)
(setq buffer-read-only t)
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 0529d223dbe..47d8ae14cfc 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -115,6 +115,17 @@ the type we want for the drop,
the action we want for the drop,
any protocol specific data.")
+(declare-function x-get-selection-internal "xselect.c"
+ (selection-symbol target-type &optional time-stamp terminal))
+
+(defconst x-dnd-xdnd-to-action
+ '(("XdndActionPrivate" . private)
+ ("XdndActionCopy" . copy)
+ ("XdndActionMove" . move)
+ ("XdndActionLink" . link)
+ ("XdndActionAsk" . ask))
+ "Mapping from XDND action types to Lisp symbols.")
+
(defvar x-dnd-empty-state [nil nil nil nil nil nil nil])
(declare-function x-register-dnd-atom "xselect.c")
@@ -336,21 +347,41 @@ nil if not."
Currently XDND, Motif and old KDE 1.x protocols are recognized."
(interactive "e")
(let* ((client-message (car (cdr (cdr event))))
- (window (posn-window (event-start event)))
- (message-atom (aref client-message 0))
- (frame (aref client-message 1))
- (format (aref client-message 2))
- (data (aref client-message 3)))
-
- (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x.
- (x-dnd-handle-old-kde event frame window message-atom format data))
-
- ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif
- (x-dnd-handle-motif event frame window message-atom format data))
-
- ((and (> (length message-atom) 4) ; XDND protocol.
- (equal "Xdnd" (substring message-atom 0 4)))
- (x-dnd-handle-xdnd event frame window message-atom format data)))))
+ (window (posn-window (event-start event))))
+ (if (eq (and (consp client-message)
+ (car client-message))
+ 'XdndSelection)
+ ;; This is an internal Emacs message caused by something being
+ ;; dropped on top of a frame.
+ (progn
+ (let ((action (cdr (assoc (symbol-name (cadr client-message))
+ x-dnd-xdnd-to-action)))
+ (targets (cddr client-message)))
+ (x-dnd-save-state window nil nil
+ (apply #'vector targets))
+ (x-dnd-maybe-call-test-function window action)
+ (unwind-protect
+ (x-dnd-drop-data event (if (framep window) window
+ (window-frame window))
+ window
+ (x-get-selection-internal
+ 'XdndSelection
+ (intern (x-dnd-current-type window)))
+ (x-dnd-current-type window))
+ (x-dnd-forget-drop window))))
+ (let ((message-atom (aref client-message 0))
+ (frame (aref client-message 1))
+ (format (aref client-message 2))
+ (data (aref client-message 3)))
+ (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x.
+ (x-dnd-handle-old-kde event frame window message-atom format data))
+
+ ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif
+ (x-dnd-handle-motif event frame window message-atom format data))
+
+ ((and (> (length message-atom) 4) ; XDND protocol.
+ (equal "Xdnd" (substring message-atom 0 4)))
+ (x-dnd-handle-xdnd event frame window message-atom format data)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -371,14 +402,6 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; XDND protocol.
-(defconst x-dnd-xdnd-to-action
- '(("XdndActionPrivate" . private)
- ("XdndActionCopy" . copy)
- ("XdndActionMove" . move)
- ("XdndActionLink" . link)
- ("XdndActionAsk" . ask))
- "Mapping from XDND action types to Lisp symbols.")
-
(declare-function x-change-window-property "xfns.c"
(prop value &optional frame type format outer-P))
@@ -425,8 +448,6 @@ otherwise return the frame coordinates."
(declare-function x-get-atom-name "xselect.c" (value &optional frame))
(declare-function x-send-client-message "xselect.c"
(display dest from message-type format values))
-(declare-function x-get-selection-internal "xselect.c"
- (selection-symbol target-type &optional time-stamp terminal))
(defun x-dnd-version-from-flags (flags)
"Return the version byte from the 32 bit FLAGS in an XDndEnter message."
@@ -478,7 +499,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
)))
(x-send-client-message
frame dnd-source frame "XdndStatus" 32 list-to-send)
- ))
+ (dnd-handle-movement (event-start event))))
((equal "XdndLeave" message)
(x-dnd-forget-drop window))
@@ -582,178 +603,195 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(2 . private)) ; Motif does not have private, so use copy for private.
"Mapping from number to operation for Motif DND.")
-(defun x-dnd-handle-motif (event frame window message-atom _format data)
- (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types)))
+(defun x-dnd-handle-motif (event frame window _message-atom _format data)
+ (let* ((message-type (cdr (assoc (logand (aref data 0) #x3f)
+ x-dnd-motif-message-types)))
+ (initiator-p (eq (lsh (aref data 0) -7) 0))
(source-byteorder (aref data 1))
(my-byteorder (byteorder))
(source-flags (x-dnd-get-motif-value data 2 2 source-byteorder))
(source-action (cdr (assoc (logand ?\xF source-flags)
x-dnd-motif-to-action))))
- (cond ((eq message-type 'XmTOP_LEVEL_ENTER)
- (let* ((dnd-source (x-dnd-get-motif-value
- data 8 4 source-byteorder))
- (selection-atom (x-dnd-get-motif-value
- data 12 4 source-byteorder))
- (atom-name (x-get-atom-name selection-atom))
- (types (when atom-name
- (x-get-selection-internal (intern atom-name)
- 'TARGETS))))
- (x-dnd-forget-drop frame)
- (when types (x-dnd-save-state window nil nil
- types
- dnd-source))))
-
- ;; Can not forget drop here, LEAVE comes before DROP_START and
- ;; we need the state in DROP_START.
- ((eq message-type 'XmTOP_LEVEL_LEAVE)
- nil)
-
- ((eq message-type 'XmDRAG_MOTION)
- (let* ((state (x-dnd-get-state-for-frame frame))
- (timestamp (x-dnd-motif-value-to-list
- (x-dnd-get-motif-value data 4 4
- source-byteorder)
- 4 my-byteorder))
- (x (x-dnd-motif-value-to-list
- (x-dnd-get-motif-value data 8 2 source-byteorder)
+ (when initiator-p
+ (cond ((eq message-type 'XmTOP_LEVEL_ENTER)
+ (let* ((dnd-source (x-dnd-get-motif-value
+ data 8 4 source-byteorder))
+ (selection-atom (x-dnd-get-motif-value
+ data 12 4 source-byteorder))
+ (atom-name (x-get-atom-name selection-atom))
+ (types (when atom-name
+ (x-get-selection-internal (intern atom-name)
+ 'TARGETS))))
+ (x-dnd-forget-drop frame)
+ (when types (x-dnd-save-state window nil nil
+ types
+ dnd-source))))
+
+ ;; Can not forget drop here, LEAVE comes before DROP_START and
+ ;; we need the state in DROP_START.
+ ((eq message-type 'XmTOP_LEVEL_LEAVE)
+ nil)
+
+ ((eq message-type 'XmDRAG_MOTION)
+ (let* ((state (x-dnd-get-state-for-frame frame))
+ (timestamp (x-dnd-motif-value-to-list
+ (x-dnd-get-motif-value data 4 4
+ source-byteorder)
+ 4 my-byteorder))
+ (x (x-dnd-motif-value-to-list
+ (x-dnd-get-motif-value data 8 2 source-byteorder)
+ 2 my-byteorder))
+ (y (x-dnd-motif-value-to-list
+ (x-dnd-get-motif-value data 10 2 source-byteorder)
+ 2 my-byteorder))
+ (dnd-source (aref state 6))
+ (first-move (not (aref state 3)))
+ (action-type (x-dnd-maybe-call-test-function
+ window
+ source-action))
+ (reply-action (car (rassoc (car action-type)
+ x-dnd-motif-to-action)))
+ (reply-flags
+ (x-dnd-motif-value-to-list
+ (if reply-action
+ (+ reply-action
+ ?\x30 ; 30: valid drop site
+ ?\x700) ; 700: can do copy, move or link
+ ?\x30) ; 30: drop site, but noop.
2 my-byteorder))
- (y (x-dnd-motif-value-to-list
- (x-dnd-get-motif-value data 10 2 source-byteorder)
- 2 my-byteorder))
- (dnd-source (aref state 6))
- (first-move (not (aref state 3)))
- (action-type (x-dnd-maybe-call-test-function
- window
- source-action))
- (reply-action (car (rassoc (car action-type)
- x-dnd-motif-to-action)))
- (reply-flags
- (x-dnd-motif-value-to-list
- (if reply-action
- (+ reply-action
- ?\x30 ; 30: valid drop site
- ?\x700) ; 700: can do copy, move or link
- ?\x30) ; 30: drop site, but noop.
- 2 my-byteorder))
- (reply (append
- (list
- (+ ?\x80 ; 0x80 indicates a reply.
- (if first-move
- 3 ; First time, reply is SITE_ENTER.
- 2)) ; Not first time, reply is DRAG_MOTION.
- my-byteorder)
- reply-flags
- timestamp
- x
- y)))
- (x-send-client-message frame
- dnd-source
- frame
- "_MOTIF_DRAG_AND_DROP_MESSAGE"
- 8
- reply)))
-
- ((eq message-type 'XmOPERATION_CHANGED)
- (let* ((state (x-dnd-get-state-for-frame frame))
- (timestamp (x-dnd-motif-value-to-list
- (x-dnd-get-motif-value data 4 4 source-byteorder)
- 4 my-byteorder))
- (dnd-source (aref state 6))
- (action-type (x-dnd-maybe-call-test-function
- window
- source-action))
- (reply-action (car (rassoc (car action-type)
- x-dnd-motif-to-action)))
- (reply-flags
- (x-dnd-motif-value-to-list
- (if reply-action
- (+ reply-action
- ?\x30 ; 30: valid drop site
- ?\x700) ; 700: can do copy, move or link
- ?\x30) ; 30: drop site, but noop
- 2 my-byteorder))
- (reply (append
- (list
- (+ ?\x80 ; 0x80 indicates a reply.
- 8) ; 8 is OPERATION_CHANGED
- my-byteorder)
- reply-flags
- timestamp)))
- (x-send-client-message frame
- dnd-source
- frame
- "_MOTIF_DRAG_AND_DROP_MESSAGE"
- 8
- reply)))
-
- ((eq message-type 'XmDROP_START)
- (let* ((x (x-dnd-motif-value-to-list
- (x-dnd-get-motif-value data 8 2 source-byteorder)
+ (reply (append
+ (list
+ (+ ?\x80 ; 0x80 indicates a reply.
+ (if first-move
+ 3 ; First time, reply is SITE_ENTER.
+ 2)) ; Not first time, reply is DRAG_MOTION.
+ my-byteorder)
+ reply-flags
+ timestamp
+ x
+ y)))
+ (x-send-client-message frame
+ dnd-source
+ frame
+ "_MOTIF_DRAG_AND_DROP_MESSAGE"
+ 8
+ reply)
+ (dnd-handle-movement (event-start event))))
+
+ ((eq message-type 'XmOPERATION_CHANGED)
+ (let* ((state (x-dnd-get-state-for-frame frame))
+ (timestamp (x-dnd-motif-value-to-list
+ (x-dnd-get-motif-value data 4 4 source-byteorder)
+ 4 my-byteorder))
+ (dnd-source (aref state 6))
+ (action-type (x-dnd-maybe-call-test-function
+ window
+ source-action))
+ (reply-action (car (rassoc (car action-type)
+ x-dnd-motif-to-action)))
+ (reply-flags
+ (x-dnd-motif-value-to-list
+ (if reply-action
+ (+ reply-action
+ ?\x30 ; 30: valid drop site
+ ?\x700) ; 700: can do copy, move or link
+ ?\x30) ; 30: drop site, but noop
2 my-byteorder))
- (y (x-dnd-motif-value-to-list
- (x-dnd-get-motif-value data 10 2 source-byteorder)
+ (reply (append
+ (list
+ (+ ?\x80 ; 0x80 indicates a reply.
+ 8) ; 8 is OPERATION_CHANGED
+ my-byteorder)
+ reply-flags
+ timestamp)))
+ (x-send-client-message frame
+ dnd-source
+ frame
+ "_MOTIF_DRAG_AND_DROP_MESSAGE"
+ 8
+ reply)))
+
+ ((eq message-type 'XmDROP_START)
+ (let* ((x (x-dnd-motif-value-to-list
+ (x-dnd-get-motif-value data 8 2 source-byteorder)
+ 2 my-byteorder))
+ (y (x-dnd-motif-value-to-list
+ (x-dnd-get-motif-value data 10 2 source-byteorder)
+ 2 my-byteorder))
+ (selection-atom (x-dnd-get-motif-value
+ data 12 4 source-byteorder))
+ (atom-name (x-get-atom-name selection-atom))
+ (dnd-source (x-dnd-get-motif-value
+ data 16 4 source-byteorder))
+ (action-type (x-dnd-maybe-call-test-function
+ window
+ source-action))
+ (reply-action (car (rassoc (car action-type)
+ x-dnd-motif-to-action)))
+ (reply-flags
+ (x-dnd-motif-value-to-list
+ (if reply-action
+ (+ reply-action
+ ?\x30 ; 30: valid drop site
+ ?\x700) ; 700: can do copy, move or link
+ (+ ?\x30 ; 30: drop site, but noop.
+ ?\x200)) ; 200: drop cancel.
2 my-byteorder))
- (selection-atom (x-dnd-get-motif-value
- data 12 4 source-byteorder))
- (atom-name (x-get-atom-name selection-atom))
- (dnd-source (x-dnd-get-motif-value
- data 16 4 source-byteorder))
- (action-type (x-dnd-maybe-call-test-function
- window
- source-action))
- (reply-action (car (rassoc (car action-type)
- x-dnd-motif-to-action)))
- (reply-flags
- (x-dnd-motif-value-to-list
- (if reply-action
- (+ reply-action
- ?\x30 ; 30: valid drop site
- ?\x700) ; 700: can do copy, move or link
- (+ ?\x30 ; 30: drop site, but noop.
- ?\x200)) ; 200: drop cancel.
- 2 my-byteorder))
- (reply (append
- (list
- (+ ?\x80 ; 0x80 indicates a reply.
- 5) ; DROP_START.
- my-byteorder)
- reply-flags
- x
- y))
- (timestamp (x-dnd-get-motif-value
- data 4 4 source-byteorder))
- action)
-
- (x-send-client-message frame
- dnd-source
- frame
- "_MOTIF_DRAG_AND_DROP_MESSAGE"
- 8
- reply)
- (setq action
- (when (and reply-action atom-name)
- (let* ((value (x-get-selection-internal
- (intern atom-name)
- (intern (x-dnd-current-type window)))))
- (when value
- (condition-case info
- (x-dnd-drop-data event frame window value
- (x-dnd-current-type window))
- (error
- (message "Error: %s" info)
- nil))))))
- (x-get-selection-internal
- (intern atom-name)
- (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE)
- timestamp)
- (x-dnd-forget-drop frame)))
-
- (t (error "Unknown Motif DND message %s %s" message-atom data)))))
+ (reply (append
+ (list
+ (+ ?\x80 ; 0x80 indicates a reply.
+ 5) ; DROP_START.
+ my-byteorder)
+ reply-flags
+ x
+ y))
+ (timestamp (x-dnd-get-motif-value
+ data 4 4 source-byteorder))
+ action)
+
+ (x-send-client-message frame
+ dnd-source
+ frame
+ "_MOTIF_DRAG_AND_DROP_MESSAGE"
+ 8
+ reply)
+ (setq action
+ (when (and reply-action atom-name)
+ (let* ((value (x-get-selection-internal
+ (intern atom-name)
+ (intern (x-dnd-current-type window)))))
+ (when value
+ (condition-case info
+ (x-dnd-drop-data event frame window value
+ (x-dnd-current-type window))
+ (error
+ (message "Error: %s" info)
+ nil))))))
+ (x-get-selection-internal
+ (intern atom-name)
+ (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE)
+ timestamp)
+ (x-dnd-forget-drop frame)))
+
+ (t (message "Unknown Motif drag-and-drop message: %s" (logand (aref data 0) #x3f)))))))
;;;
+
+
+;;; Handling drops.
+
+(defun x-dnd-handle-unsupported-drop (targets _x _y action _window-id _frame)
+ "Return non-nil if the drop described by TARGETS and ACTION should not proceeed."
+ (not (and (or (eq action 'XdndActionCopy)
+ (eq action 'XdndActionMove))
+ (or (member "STRING" targets)
+ (member "UTF8_STRING" targets)
+ (member "COMPOUND_TEXT" targets)
+ (member "TEXT" targets)))))
+
(provide 'x-dnd)
;;; x-dnd.el ends here
diff --git a/msdos/sed1v2.inp b/msdos/sed1v2.inp
index cc29ad02819..4cc733ee79e 100644
--- a/msdos/sed1v2.inp
+++ b/msdos/sed1v2.inp
@@ -117,6 +117,10 @@ s/ *@WEBP_LIBS@//
/^XFIXES_CFLAGS *=/s/@XFIXES_CFLAGS@//
/^XDBE_LIBS *=/s/@XDBE_LIBS@//
/^XDBE_CFLAGS *=/s/@XDBE_CFLAGS@//
+/^XCOMPOSITE_LIBS *=/s/@XCOMPOSITE_LIBS@//
+/^XCOMPOSITE_CFLAGS *=/s/@XCOMPOSITE_CFLAGS@//
+/^XSHAPE_LIBS *=/s/@XSHAPE_LIBS@//
+/^XSHAPE_CFLAGS *=/s/@XSHAPE_CFLAGS@//
/^XINPUT_LIBS *=/s/@XINPUT_LIBS@//
/^XINPUT_CFLAGS *=/s/@XINPUT_CFLAGS@//
/^XSYNC_LIBS *=/s/@XSYNC_LIBS@//
diff --git a/src/Makefile.in b/src/Makefile.in
index 2b7c4bb316c..7d15b7afd51 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -271,6 +271,12 @@ XSYNC_CFLAGS = @XSYNC_CFLAGS@
XDBE_LIBS = @XDBE_LIBS@
XDBE_CFLAGS = @XDBE_CFLAGS@
+XCOMPOSITE_LIBS = @XCOMPOSITE_LIBS@
+XCOMPOSITE_CFLAGS = @XCOMPOSITE_CFLAGS@
+
+XSHAPE_LIBS = @XSHAPE_LIBS@
+XSHAPE_CFLAGS = @XSHAPE_CFLAGS@
+
## widget.o if USE_X_TOOLKIT, otherwise empty.
WIDGET_OBJ=@WIDGET_OBJ@
@@ -402,7 +408,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \
$(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \
$(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) $(XSYNC_CFLAGS) \
$(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \
- $(WERROR_CFLAGS) $(HAIKU_CFLAGS)
+ $(WERROR_CFLAGS) $(HAIKU_CFLAGS) $(XCOMPOSITE_CFLAGS) $(XSHAPE_CFLAGS)
ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \
$(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \
@@ -428,7 +434,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
minibuf.o fileio.o dired.o \
cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \
alloc.o pdumper.o data.o doc.o editfns.o callint.o \
- eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \
+ eval.o floatfns.o fns.o sort.o font.o print.o lread.o $(MODULES_OBJ) \
syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \
process.o gnutls.o callproc.o \
region-cache.o sound.o timefns.o atimer.o \
@@ -559,7 +565,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
$(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) \
- $(SQLITE3_LIBS)
+ $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS)
## FORCE it so that admin/unidata can decide whether this file is
## up-to-date. Although since charprop depends on bootstrap-emacs,
diff --git a/src/alloc.c b/src/alloc.c
index c19e3dabb6e..8fd981a51f9 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -445,26 +445,11 @@ static void compact_small_strings (void);
static void free_large_strings (void);
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
-/* Forward declare mark accessor functions: they're used all over the
- place. */
-
-inline static bool vector_marked_p (const struct Lisp_Vector *v);
-inline static void set_vector_marked (struct Lisp_Vector *v);
-
-inline static bool vectorlike_marked_p (const union vectorlike_header *v);
-inline static void set_vectorlike_marked (union vectorlike_header *v);
-
-inline static bool cons_marked_p (const struct Lisp_Cons *c);
-inline static void set_cons_marked (struct Lisp_Cons *c);
-
-inline static bool string_marked_p (const struct Lisp_String *s);
-inline static void set_string_marked (struct Lisp_String *s);
-
-inline static bool symbol_marked_p (const struct Lisp_Symbol *s);
-inline static void set_symbol_marked (struct Lisp_Symbol *s);
-
-inline static bool interval_marked_p (INTERVAL i);
-inline static void set_interval_marked (INTERVAL i);
+static bool vector_marked_p (struct Lisp_Vector const *);
+static bool vectorlike_marked_p (union vectorlike_header const *);
+static void set_vectorlike_marked (union vectorlike_header *);
+static bool interval_marked_p (INTERVAL);
+static void set_interval_marked (INTERVAL);
/* When scanning the C stack for live Lisp objects, Emacs keeps track of
what memory allocated via lisp_malloc and lisp_align_malloc is intended
@@ -4997,7 +4982,7 @@ marking. Emacs has determined that the method it uses to do the\n\
marking will likely work on your system, but this isn't sure.\n\
\n\
If you are a system-programmer, or can get the help of a local wizard\n\
-who is, please take a look at the function mark_stack in alloc.c, and\n\
+who is, please take a look at the function mark_c_stack in alloc.c, and\n\
verify that the methods used are appropriate for your system.\n\
\n\
Please mail the result to <emacs-devel@gnu.org>.\n\
@@ -5010,7 +4995,7 @@ marking. Emacs has determined that the default method it uses to do the\n\
marking will not work on your system. We will need a system-dependent\n\
solution for your system.\n\
\n\
-Please take a look at the function mark_stack in alloc.c, and\n\
+Please take a look at the function mark_c_stack in alloc.c, and\n\
try to find a way to make it work on your system.\n\
\n\
Note that you may get false negatives, depending on the compiler.\n\
@@ -5152,7 +5137,7 @@ typedef union
from the stack start. */
void
-mark_stack (char const *bottom, char const *end)
+mark_c_stack (char const *bottom, char const *end)
{
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
@@ -6100,6 +6085,8 @@ maybe_garbage_collect (void)
garbage_collect ();
}
+static inline bool mark_stack_empty_p (void);
+
/* Subroutine of Fgarbage_collect that does most of the work. */
void
garbage_collect (void)
@@ -6115,6 +6102,8 @@ garbage_collect (void)
if (garbage_collection_inhibited)
return;
+ eassert(mark_stack_empty_p ());
+
/* Record this function, so it appears on the profiler's backtraces. */
record_in_backtrace (QAutomatic_GC, 0, 0);
@@ -6207,6 +6196,10 @@ garbage_collect (void)
mark_fringe_data ();
#endif
+#ifdef HAVE_X_WINDOWS
+ mark_xterm ();
+#endif
+
/* Everything is now marked, except for the data in font caches,
undo lists, and finalizers. The first two are compacted by
removing an items which aren't reachable otherwise. */
@@ -6237,6 +6230,8 @@ garbage_collect (void)
mark_and_sweep_weak_table_contents ();
eassert (weak_hash_tables == NULL);
+ eassert (mark_stack_empty_p ());
+
gc_sweep ();
unmark_main_thread ();
@@ -6410,15 +6405,25 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
}
}
+/* Whether to remember a few of the last marked values for debugging. */
+#define GC_REMEMBER_LAST_MARKED 0
+
+#if GC_REMEMBER_LAST_MARKED
enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */
Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE;
static int last_marked_index;
+#endif
+/* Whether to enable the mark_object_loop_halt debugging feature. */
+#define GC_CDR_COUNT 0
+
+#if GC_CDR_COUNT
/* For debugging--call abort when we cdr down this many
links of a list, in mark_object. In debugging,
the call to abort will hit a breakpoint.
Normally this is zero and the check never goes off. */
ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
+#endif
static void
mark_vectorlike (union vectorlike_header *header)
@@ -6472,19 +6477,6 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
}
}
-NO_INLINE /* To reduce stack depth in mark_object. */
-static Lisp_Object
-mark_compiled (struct Lisp_Vector *ptr)
-{
- int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
-
- set_vector_marked (ptr);
- for (i = 0; i < size; i++)
- if (i != COMPILED_CONSTANTS)
- mark_object (ptr->contents[i]);
- return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
-}
-
/* Mark the chain of overlays starting at PTR. */
static void
@@ -6637,110 +6629,160 @@ mark_window (struct Lisp_Vector *ptr)
(w, mark_discard_killed_buffers (w->next_buffers));
}
-static void
-mark_hash_table (struct Lisp_Vector *ptr)
-{
- struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
-
- mark_vectorlike (&h->header);
- mark_object (h->test.name);
- mark_object (h->test.user_hash_function);
- mark_object (h->test.user_cmp_function);
- /* If hash table is not weak, mark all keys and values. For weak
- tables, mark only the vector and not its contents --- that's what
- makes it weak. */
- if (NILP (h->weak))
- mark_object (h->key_and_value);
- else
+/* Entry of the mark stack. */
+struct mark_entry
+{
+ ptrdiff_t n; /* number of values, or 0 if a single value */
+ union {
+ Lisp_Object value; /* when n = 0 */
+ Lisp_Object *values; /* when n > 0 */
+ } u;
+};
+
+/* This stack is used during marking for traversing data structures without
+ using C recursion. */
+struct mark_stack
+{
+ struct mark_entry *stack; /* base of stack */
+ ptrdiff_t size; /* allocated size in entries */
+ ptrdiff_t sp; /* current number of entries */
+};
+
+static struct mark_stack mark_stk = {NULL, 0, 0};
+
+static inline bool
+mark_stack_empty_p (void)
+{
+ return mark_stk.sp <= 0;
+}
+
+/* Pop and return a value from the mark stack (which must be nonempty). */
+static inline Lisp_Object
+mark_stack_pop (void)
+{
+ eassume (!mark_stack_empty_p ());
+ struct mark_entry *e = &mark_stk.stack[mark_stk.sp - 1];
+ if (e->n == 0) /* single value */
{
- eassert (h->next_weak == NULL);
- h->next_weak = weak_hash_tables;
- weak_hash_tables = h;
- set_vector_marked (XVECTOR (h->key_and_value));
+ --mark_stk.sp;
+ return e->u.value;
}
+ /* Array of values: pop them left to right, which seems to be slightly
+ faster than right to left. */
+ e->n--;
+ if (e->n == 0)
+ --mark_stk.sp; /* last value consumed */
+ return (++e->u.values)[-1];
}
-void
-mark_objects (Lisp_Object *obj, ptrdiff_t n)
+NO_INLINE static void
+grow_mark_stack (void)
{
- for (ptrdiff_t i = 0; i < n; i++)
- mark_object (obj[i]);
+ struct mark_stack *ms = &mark_stk;
+ eassert (ms->sp == ms->size);
+ ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1;
+ ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack);
+ eassert (ms->sp < ms->size);
}
-/* Determine type of generic Lisp_Object and mark it accordingly.
+/* Push VALUE onto the mark stack. */
+static inline void
+mark_stack_push_value (Lisp_Object value)
+{
+ if (mark_stk.sp >= mark_stk.size)
+ grow_mark_stack ();
+ mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = 0, .u.value = value};
+}
- This function implements a straightforward depth-first marking
- algorithm and so the recursion depth may be very high (a few
- tens of thousands is not uncommon). To minimize stack usage,
- a few cold paths are moved out to NO_INLINE functions above.
- In general, inlining them doesn't help you to gain more speed. */
+/* Push the N values at VALUES onto the mark stack. */
+static inline void
+mark_stack_push_values (Lisp_Object *values, ptrdiff_t n)
+{
+ eassume (n >= 0);
+ if (n == 0)
+ return;
+ if (mark_stk.sp >= mark_stk.size)
+ grow_mark_stack ();
+ mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = n,
+ .u.values = values};
+}
-void
-mark_object (Lisp_Object arg)
+/* Traverse and mark objects on the mark stack above BASE_SP.
+
+ Traversal is depth-first using the mark stack for most common
+ object types. Recursion is used for other types, in the hope that
+ they are rare enough that C stack usage is kept low. */
+static void
+process_mark_stack (ptrdiff_t base_sp)
{
- register Lisp_Object obj;
- void *po;
#if GC_CHECK_MARKED_OBJECTS
struct mem_node *m = NULL;
#endif
+#if GC_CDR_COUNT
ptrdiff_t cdr_count = 0;
+#endif
- obj = arg;
- loop:
+ eassume (mark_stk.sp >= base_sp && base_sp >= 0);
- po = XPNTR (obj);
- if (PURE_P (po))
- return;
+ while (mark_stk.sp > base_sp)
+ {
+ Lisp_Object obj = mark_stack_pop ();
+ mark_obj: ;
+ void *po = XPNTR (obj);
+ if (PURE_P (po))
+ continue;
- last_marked[last_marked_index++] = obj;
- last_marked_index &= LAST_MARKED_SIZE - 1;
+#if GC_REMEMBER_LAST_MARKED
+ last_marked[last_marked_index++] = obj;
+ last_marked_index &= LAST_MARKED_SIZE - 1;
+#endif
- /* Perform some sanity checks on the objects marked here. Abort if
- we encounter an object we know is bogus. This increases GC time
- by ~80%. */
+ /* Perform some sanity checks on the objects marked here. Abort if
+ we encounter an object we know is bogus. This increases GC time
+ by ~80%. */
#if GC_CHECK_MARKED_OBJECTS
- /* Check that the object pointed to by PO is known to be a Lisp
- structure allocated from the heap. */
+ /* Check that the object pointed to by PO is known to be a Lisp
+ structure allocated from the heap. */
#define CHECK_ALLOCATED() \
- do { \
- if (pdumper_object_p (po)) \
- { \
- if (!pdumper_object_p_precise (po)) \
- emacs_abort (); \
- break; \
- } \
- m = mem_find (po); \
- if (m == MEM_NIL) \
- emacs_abort (); \
- } while (0)
-
- /* Check that the object pointed to by PO is live, using predicate
- function LIVEP. */
-#define CHECK_LIVE(LIVEP, MEM_TYPE) \
- do { \
- if (pdumper_object_p (po)) \
- break; \
- if (! (m->type == MEM_TYPE && LIVEP (m, po))) \
- emacs_abort (); \
- } while (0)
-
- /* Check both of the above conditions, for non-symbols. */
-#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \
- do { \
- CHECK_ALLOCATED (); \
- CHECK_LIVE (LIVEP, MEM_TYPE); \
- } while (false)
-
- /* Check both of the above conditions, for symbols. */
-#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
- do { \
- if (!c_symbol_p (ptr)) \
- { \
- CHECK_ALLOCATED (); \
- CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \
- } \
- } while (false)
+ do { \
+ if (pdumper_object_p (po)) \
+ { \
+ if (!pdumper_object_p_precise (po)) \
+ emacs_abort (); \
+ break; \
+ } \
+ m = mem_find (po); \
+ if (m == MEM_NIL) \
+ emacs_abort (); \
+ } while (0)
+
+ /* Check that the object pointed to by PO is live, using predicate
+ function LIVEP. */
+#define CHECK_LIVE(LIVEP, MEM_TYPE) \
+ do { \
+ if (pdumper_object_p (po)) \
+ break; \
+ if (! (m->type == MEM_TYPE && LIVEP (m, po))) \
+ emacs_abort (); \
+ } while (0)
+
+ /* Check both of the above conditions, for non-symbols. */
+#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \
+ do { \
+ CHECK_ALLOCATED (); \
+ CHECK_LIVE (LIVEP, MEM_TYPE); \
+ } while (false)
+
+ /* Check both of the above conditions, for symbols. */
+#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
+ do { \
+ if (!c_symbol_p (ptr)) \
+ { \
+ CHECK_ALLOCATED (); \
+ CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \
+ } \
+ } while (false)
#else /* not GC_CHECK_MARKED_OBJECTS */
@@ -6749,199 +6791,220 @@ mark_object (Lisp_Object arg)
#endif /* not GC_CHECK_MARKED_OBJECTS */
- switch (XTYPE (obj))
- {
- case Lisp_String:
- {
- register struct Lisp_String *ptr = XSTRING (obj);
- if (string_marked_p (ptr))
- break;
- CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING);
- set_string_marked (ptr);
- mark_interval_tree (ptr->u.s.intervals);
+ switch (XTYPE (obj))
+ {
+ case Lisp_String:
+ {
+ register struct Lisp_String *ptr = XSTRING (obj);
+ if (string_marked_p (ptr))
+ break;
+ CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING);
+ set_string_marked (ptr);
+ mark_interval_tree (ptr->u.s.intervals);
#ifdef GC_CHECK_STRING_BYTES
- /* Check that the string size recorded in the string is the
- same as the one recorded in the sdata structure. */
- string_bytes (ptr);
+ /* Check that the string size recorded in the string is the
+ same as the one recorded in the sdata structure. */
+ string_bytes (ptr);
#endif /* GC_CHECK_STRING_BYTES */
- }
- break;
+ }
+ break;
- case Lisp_Vectorlike:
- {
- register struct Lisp_Vector *ptr = XVECTOR (obj);
+ case Lisp_Vectorlike:
+ {
+ register struct Lisp_Vector *ptr = XVECTOR (obj);
- if (vector_marked_p (ptr))
- break;
+ if (vector_marked_p (ptr))
+ break;
- enum pvec_type pvectype
- = PSEUDOVECTOR_TYPE (ptr);
+ enum pvec_type pvectype
+ = PSEUDOVECTOR_TYPE (ptr);
#ifdef GC_CHECK_MARKED_OBJECTS
- if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
- {
- m = mem_find (po);
- if (m == MEM_NIL)
- emacs_abort ();
- if (m->type == MEM_TYPE_VECTORLIKE)
- CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE);
- else
- CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK);
- }
+ if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
+ {
+ m = mem_find (po);
+ if (m == MEM_NIL)
+ emacs_abort ();
+ if (m->type == MEM_TYPE_VECTORLIKE)
+ CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE);
+ else
+ CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK);
+ }
#endif
- switch (pvectype)
- {
- case PVEC_BUFFER:
- mark_buffer ((struct buffer *) ptr);
- break;
-
- case PVEC_COMPILED:
- /* Although we could treat this just like a vector, mark_compiled
- returns the COMPILED_CONSTANTS element, which is marked at the
- next iteration of goto-loop here. This is done to avoid a few
- recursive calls to mark_object. */
- obj = mark_compiled (ptr);
- if (!NILP (obj))
- goto loop;
- break;
-
- case PVEC_FRAME:
- mark_frame (ptr);
- break;
-
- case PVEC_WINDOW:
- mark_window (ptr);
- break;
-
- case PVEC_HASH_TABLE:
- mark_hash_table (ptr);
- break;
-
- case PVEC_CHAR_TABLE:
- case PVEC_SUB_CHAR_TABLE:
- mark_char_table (ptr, (enum pvec_type) pvectype);
- break;
-
- case PVEC_BOOL_VECTOR:
- /* bool vectors in a dump are permanently "marked", since
- they're in the old section and don't have mark bits.
- If we're looking at a dumped bool vector, we should
- have aborted above when we called vector_marked_p, so
- we should never get here. */
- eassert (!pdumper_object_p (ptr));
- set_vector_marked (ptr);
- break;
-
- case PVEC_OVERLAY:
- mark_overlay (XOVERLAY (obj));
- break;
-
- case PVEC_SUBR:
-#ifdef HAVE_NATIVE_COMP
- if (SUBR_NATIVE_COMPILEDP (obj))
+ switch (pvectype)
{
+ case PVEC_BUFFER:
+ mark_buffer ((struct buffer *) ptr);
+ break;
+
+ case PVEC_FRAME:
+ mark_frame (ptr);
+ break;
+
+ case PVEC_WINDOW:
+ mark_window (ptr);
+ break;
+
+ case PVEC_HASH_TABLE:
+ {
+ struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *)ptr;
+ ptrdiff_t size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
+ set_vector_marked (ptr);
+ mark_stack_push_values (ptr->contents, size);
+ mark_stack_push_value (h->test.name);
+ mark_stack_push_value (h->test.user_hash_function);
+ mark_stack_push_value (h->test.user_cmp_function);
+ if (NILP (h->weak))
+ mark_stack_push_value (h->key_and_value);
+ else
+ {
+ /* For weak tables, mark only the vector and not its
+ contents --- that's what makes it weak. */
+ eassert (h->next_weak == NULL);
+ h->next_weak = weak_hash_tables;
+ weak_hash_tables = h;
+ set_vector_marked (XVECTOR (h->key_and_value));
+ }
+ break;
+ }
+
+ case PVEC_CHAR_TABLE:
+ case PVEC_SUB_CHAR_TABLE:
+ mark_char_table (ptr, (enum pvec_type) pvectype);
+ break;
+
+ case PVEC_BOOL_VECTOR:
+ /* bool vectors in a dump are permanently "marked", since
+ they're in the old section and don't have mark bits.
+ If we're looking at a dumped bool vector, we should
+ have aborted above when we called vector_marked_p, so
+ we should never get here. */
+ eassert (!pdumper_object_p (ptr));
set_vector_marked (ptr);
- struct Lisp_Subr *subr = XSUBR (obj);
- mark_object (subr->native_intspec);
- mark_object (subr->native_comp_u);
- mark_object (subr->lambda_list);
- mark_object (subr->type);
- }
+ break;
+
+ case PVEC_OVERLAY:
+ mark_overlay (XOVERLAY (obj));
+ break;
+
+ case PVEC_SUBR:
+#ifdef HAVE_NATIVE_COMP
+ if (SUBR_NATIVE_COMPILEDP (obj))
+ {
+ set_vector_marked (ptr);
+ struct Lisp_Subr *subr = XSUBR (obj);
+ mark_stack_push_value (subr->native_intspec);
+ mark_stack_push_value (subr->command_modes);
+ mark_stack_push_value (subr->native_comp_u);
+ mark_stack_push_value (subr->lambda_list);
+ mark_stack_push_value (subr->type);
+ }
#endif
- break;
+ break;
- case PVEC_FREE:
- emacs_abort ();
+ case PVEC_FREE:
+ emacs_abort ();
- default:
- /* A regular vector, or a pseudovector needing no special
- treatment. */
- mark_vectorlike (&ptr->header);
+ default:
+ {
+ /* A regular vector or pseudovector needing no special
+ treatment. */
+ ptrdiff_t size = ptr->header.size;
+ if (size & PSEUDOVECTOR_FLAG)
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ set_vector_marked (ptr);
+ mark_stack_push_values (ptr->contents, size);
+ }
+ break;
+ }
}
- }
- break;
+ break;
- case Lisp_Symbol:
- {
- struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
- nextsym:
- if (symbol_marked_p (ptr))
- break;
- CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
- set_symbol_marked (ptr);
- /* Attempt to catch bogus objects. */
- eassert (valid_lisp_object_p (ptr->u.s.function));
- mark_object (ptr->u.s.function);
- mark_object (ptr->u.s.plist);
- switch (ptr->u.s.redirect)
+ case Lisp_Symbol:
{
- case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
- case SYMBOL_VARALIAS:
- {
- Lisp_Object tem;
- XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
- mark_object (tem);
+ struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
+ nextsym:
+ if (symbol_marked_p (ptr))
break;
- }
- case SYMBOL_LOCALIZED:
- mark_localized_symbol (ptr);
- break;
- case SYMBOL_FORWARDED:
- /* If the value is forwarded to a buffer or keyboard field,
- these are marked when we see the corresponding object.
- And if it's forwarded to a C variable, either it's not
- a Lisp_Object var, or it's staticpro'd already. */
- break;
- default: emacs_abort ();
+ CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
+ set_symbol_marked (ptr);
+ /* Attempt to catch bogus objects. */
+ eassert (valid_lisp_object_p (ptr->u.s.function));
+ mark_stack_push_value (ptr->u.s.function);
+ mark_stack_push_value (ptr->u.s.plist);
+ switch (ptr->u.s.redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ mark_stack_push_value (SYMBOL_VAL (ptr));
+ break;
+ case SYMBOL_VARALIAS:
+ {
+ Lisp_Object tem;
+ XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
+ mark_stack_push_value (tem);
+ break;
+ }
+ case SYMBOL_LOCALIZED:
+ mark_localized_symbol (ptr);
+ break;
+ case SYMBOL_FORWARDED:
+ /* If the value is forwarded to a buffer or keyboard field,
+ these are marked when we see the corresponding object.
+ And if it's forwarded to a C variable, either it's not
+ a Lisp_Object var, or it's staticpro'd already. */
+ break;
+ default: emacs_abort ();
+ }
+ if (!PURE_P (XSTRING (ptr->u.s.name)))
+ set_string_marked (XSTRING (ptr->u.s.name));
+ mark_interval_tree (string_intervals (ptr->u.s.name));
+ /* Inner loop to mark next symbol in this bucket, if any. */
+ po = ptr = ptr->u.s.next;
+ if (ptr)
+ goto nextsym;
}
- if (!PURE_P (XSTRING (ptr->u.s.name)))
- set_string_marked (XSTRING (ptr->u.s.name));
- mark_interval_tree (string_intervals (ptr->u.s.name));
- /* Inner loop to mark next symbol in this bucket, if any. */
- po = ptr = ptr->u.s.next;
- if (ptr)
- goto nextsym;
- }
- break;
-
- case Lisp_Cons:
- {
- struct Lisp_Cons *ptr = XCONS (obj);
- if (cons_marked_p (ptr))
break;
- CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS);
- set_cons_marked (ptr);
- /* If the cdr is nil, avoid recursion for the car. */
- if (NILP (ptr->u.s.u.cdr))
+
+ case Lisp_Cons:
{
+ struct Lisp_Cons *ptr = XCONS (obj);
+ if (cons_marked_p (ptr))
+ break;
+ CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS);
+ set_cons_marked (ptr);
+ /* Avoid growing the stack if the cdr is nil.
+ In any case, make sure the car is expanded first. */
+ if (!NILP (ptr->u.s.u.cdr))
+ {
+ mark_stack_push_value (ptr->u.s.u.cdr);
+#if GC_CDR_COUNT
+ cdr_count++;
+ if (cdr_count == mark_object_loop_halt)
+ emacs_abort ();
+#endif
+ }
+ /* Speedup hack for the common case (successive list elements). */
obj = ptr->u.s.car;
- cdr_count = 0;
- goto loop;
+ goto mark_obj;
}
- mark_object (ptr->u.s.car);
- obj = ptr->u.s.u.cdr;
- cdr_count++;
- if (cdr_count == mark_object_loop_halt)
- emacs_abort ();
- goto loop;
- }
- case Lisp_Float:
- CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT);
- /* Do not mark floats stored in a dump image: these floats are
- "cold" and do not have mark bits. */
- if (pdumper_object_p (XFLOAT (obj)))
- eassert (pdumper_cold_object_p (XFLOAT (obj)));
- else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
- XFLOAT_MARK (XFLOAT (obj));
- break;
+ case Lisp_Float:
+ CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT);
+ /* Do not mark floats stored in a dump image: these floats are
+ "cold" and do not have mark bits. */
+ if (pdumper_object_p (XFLOAT (obj)))
+ eassert (pdumper_cold_object_p (XFLOAT (obj)));
+ else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
+ XFLOAT_MARK (XFLOAT (obj));
+ break;
- case_Lisp_Int:
- break;
+ case_Lisp_Int:
+ break;
- default:
- emacs_abort ();
+ default:
+ emacs_abort ();
+ }
}
#undef CHECK_LIVE
@@ -6949,6 +7012,22 @@ mark_object (Lisp_Object arg)
#undef CHECK_ALLOCATED_AND_LIVE
}
+void
+mark_object (Lisp_Object obj)
+{
+ ptrdiff_t sp = mark_stk.sp;
+ mark_stack_push_value (obj);
+ process_mark_stack (sp);
+}
+
+void
+mark_objects (Lisp_Object *objs, ptrdiff_t n)
+{
+ ptrdiff_t sp = mark_stk.sp;
+ mark_stack_push_values (objs, n);
+ process_mark_stack (sp);
+}
+
/* Mark the Lisp pointers in the terminal objects.
Called by Fgarbage_collect. */
diff --git a/src/bytecode.c b/src/bytecode.c
index ed1f6ca4a85..62464986160 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -452,7 +452,7 @@ DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats,
}
/* Whether a stack pointer is valid in the current frame. */
-INLINE bool
+static bool
valid_sp (struct bc_thread_state *bc, Lisp_Object *sp)
{
struct bc_frame *fp = bc->fp;
diff --git a/src/callproc.c b/src/callproc.c
index 018c9ce6909..dd162f36a6c 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -85,6 +85,10 @@ extern char **environ;
#include "nsterm.h"
#endif
+#ifdef HAVE_PGTK
+#include "pgtkterm.h"
+#endif
+
/* Pattern used by call-process-region to make temp files. */
static Lisp_Object Vtemp_file_name_pattern;
@@ -1335,7 +1339,8 @@ emacs_posix_spawn_init_actions (posix_spawn_file_actions_t *actions,
}
static int
-emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes)
+emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes,
+ const sigset_t *oldset)
{
int error = posix_spawnattr_init (attributes);
if (error != 0)
@@ -1377,11 +1382,7 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes)
goto out;
/* Stop blocking SIGCHLD in the child. */
- sigset_t oldset;
- error = pthread_sigmask (SIG_SETMASK, NULL, &oldset);
- if (error != 0)
- goto out;
- error = posix_spawnattr_setsigmask (attributes, &oldset);
+ error = posix_spawnattr_setsigmask (attributes, oldset);
if (error != 0)
goto out;
@@ -1392,23 +1393,6 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes)
return error;
}
-static int
-emacs_posix_spawn_init (posix_spawn_file_actions_t *actions,
- posix_spawnattr_t *attributes, int std_in,
- int std_out, int std_err, const char *cwd)
-{
- int error = emacs_posix_spawn_init_actions (actions, std_in,
- std_out, std_err, cwd);
- if (error != 0)
- return error;
-
- error = emacs_posix_spawn_init_attributes (attributes);
- if (error != 0)
- return error;
-
- return 0;
-}
-
#endif
/* Start a new asynchronous subprocess. If successful, return zero
@@ -1443,9 +1427,12 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err,
if (use_posix_spawn)
{
/* Initialize optional attributes before blocking. */
- int error
- = emacs_posix_spawn_init (&actions, &attributes, std_in,
- std_out, std_err, cwd);
+ int error = emacs_posix_spawn_init_actions (&actions, std_in,
+ std_out, std_err, cwd);
+ if (error != 0)
+ return error;
+
+ error = emacs_posix_spawn_init_attributes (&attributes, oldset);
if (error != 0)
return error;
}
@@ -1704,6 +1691,7 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value,
/* For DISPLAY try to get the values from the frame or the initial env. */
if (strcmp (var, "DISPLAY") == 0)
{
+#ifndef HAVE_PGTK
Lisp_Object display
= Fframe_parameter (NILP (frame) ? selected_frame : frame, Qdisplay);
if (STRINGP (display))
@@ -1712,6 +1700,7 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value,
*valuelen = SBYTES (display);
return 1;
}
+#endif
/* If still not found, Look for DISPLAY in Vinitial_environment. */
if (getenv_internal_1 (var, varlen, value, valuelen,
Vinitial_environment))
@@ -1829,6 +1818,18 @@ make_environment_block (Lisp_Object current_dir)
if (NILP (display))
{
Lisp_Object tmp = Fframe_parameter (selected_frame, Qdisplay);
+
+#ifdef HAVE_PGTK
+ /* The only time GDK actually returns correct information is
+ when it's running under X Windows. DISPLAY shouldn't be
+ set to a Wayland display either, since that's an X specific
+ variable. */
+ if (FRAME_WINDOW_P (SELECTED_FRAME ())
+ && strcmp (G_OBJECT_TYPE_NAME (FRAME_X_DISPLAY (SELECTED_FRAME ())),
+ "GdkX11Display"))
+ tmp = Qnil;
+#endif
+
if (!STRINGP (tmp) && CONSP (Vinitial_environment))
/* If still not found, Look for DISPLAY in Vinitial_environment. */
tmp = Fgetenv_internal (build_string ("DISPLAY"),
diff --git a/src/coding.c b/src/coding.c
index c16598d275d..2bed293d571 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -1131,7 +1131,6 @@ detect_coding_utf_8 (struct coding_system *coding,
ptrdiff_t consumed_chars = 0;
bool bom_found = 0;
ptrdiff_t nchars = coding->head_ascii;
- int eol_seen = coding->eol_seen;
detect_info->checked |= CATEGORY_MASK_UTF_8;
/* A coding system of this category is always ASCII compatible. */
@@ -1161,15 +1160,10 @@ detect_coding_utf_8 (struct coding_system *coding,
{
if (src < src_end && *src == '\n')
{
- eol_seen |= EOL_SEEN_CRLF;
src++;
nchars++;
}
- else
- eol_seen |= EOL_SEEN_CR;
}
- else if (c == '\n')
- eol_seen |= EOL_SEEN_LF;
continue;
}
ONE_MORE_BYTE (c1);
diff --git a/src/comp.c b/src/comp.c
index 6449eedb278..398f35ddb0b 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -447,7 +447,7 @@ load_gccjit_if_necessary (bool mandatory)
/* Increase this number to force a new Vcomp_abi_hash to be generated. */
-#define ABI_VERSION "4"
+#define ABI_VERSION "5"
/* Length of the hashes used for eln file naming. */
#define HASH_LENGTH 8
@@ -516,8 +516,6 @@ typedef struct {
ptrdiff_t size;
} f_reloc_t;
-sigset_t saved_sigset;
-
static f_reloc_t freloc;
#define NUM_CAST_TYPES 15
@@ -648,7 +646,7 @@ typedef struct {
static comp_t comp;
-FILE *logfile = NULL;
+static FILE *logfile;
/* This is used for serialized objects by the reload mechanism. */
typedef struct {
@@ -666,16 +664,16 @@ typedef struct {
Helper functions called by the run-time.
*/
-void helper_unwind_protect (Lisp_Object handler);
-Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x);
-Lisp_Object helper_unbind_n (Lisp_Object n);
-void helper_save_restriction (void);
-bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
-struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a);
+static void helper_unwind_protect (Lisp_Object);
+static Lisp_Object helper_unbind_n (Lisp_Object);
+static void helper_save_restriction (void);
+static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type);
+static struct Lisp_Symbol_With_Pos *
+helper_GET_SYMBOL_WITH_POSITION (Lisp_Object);
/* Note: helper_link_table must match the list created by
`declare_runtime_imported_funcs'. */
-void *helper_link_table[] =
+static void *helper_link_table[] =
{ wrong_type_argument,
helper_PSEUDOVECTOR_TYPEP_XUNTAG,
pure_write_error,
@@ -4971,12 +4969,11 @@ unknown (before GCC version 10). */)
/******************************************************************************/
/* Helper functions called from the run-time. */
-/* These can't be statics till shared mechanism is used to solve relocations. */
/* Note: this are all potentially definable directly to gcc and are here just */
/* for laziness. Change this if a performance impact is measured. */
/******************************************************************************/
-void
+static void
helper_unwind_protect (Lisp_Object handler)
{
/* Support for a function here is new in 24.4. */
@@ -4984,28 +4981,20 @@ helper_unwind_protect (Lisp_Object handler)
handler);
}
-Lisp_Object
-helper_temp_output_buffer_setup (Lisp_Object x)
-{
- CHECK_STRING (x);
- temp_output_buffer_setup (SSDATA (x));
- return Vstandard_output;
-}
-
-Lisp_Object
+static Lisp_Object
helper_unbind_n (Lisp_Object n)
{
return unbind_to (specpdl_ref_add (SPECPDL_INDEX (), -XFIXNUM (n)), Qnil);
}
-void
+static void
helper_save_restriction (void)
{
record_unwind_protect (save_restriction_restore,
save_restriction_save ());
}
-bool
+static bool
helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
{
return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
@@ -5013,7 +5002,7 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
code);
}
-struct Lisp_Symbol_With_Pos *
+static struct Lisp_Symbol_With_Pos *
helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
{
if (!SYMBOL_WITH_POS_P (a))
@@ -5032,6 +5021,12 @@ return_nil (Lisp_Object arg)
{
return Qnil;
}
+
+static Lisp_Object
+directory_files_matching (Lisp_Object name, Lisp_Object match)
+{
+ return Fdirectory_files (name, Qt, match, Qnil, Qnil);
+}
#endif
/* Windows does not let us delete a .eln file that is currently loaded
@@ -5049,11 +5044,11 @@ eln_load_path_final_clean_up (void)
FOR_EACH_TAIL (dir_tail)
{
Lisp_Object files_in_dir =
- internal_condition_case_5 (Fdirectory_files,
+ internal_condition_case_2 (directory_files_matching,
Fexpand_file_name (Vcomp_native_version_dir,
XCAR (dir_tail)),
- Qt, build_string ("\\.eln\\.old\\'"), Qnil,
- Qnil, Qt, return_nil);
+ build_string ("\\.eln\\.old\\'"),
+ Qt, return_nil);
FOR_EACH_TAIL (files_in_dir)
internal_delete_file (XCAR (files_in_dir));
}
@@ -5411,7 +5406,7 @@ native_function_doc (Lisp_Object function)
static Lisp_Object
make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx,
- Lisp_Object intspec, Lisp_Object comp_u)
+ Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u)
{
struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
dynlib_handle_ptr handle = cu->handle;
@@ -5445,6 +5440,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY;
x->s.symbol_name = xstrdup (SSDATA (symbol_name));
x->s.native_intspec = intspec;
+ x->s.command_modes = command_modes;
x->s.doc = XFIXNUM (doc_idx);
#ifdef HAVE_NATIVE_COMP
x->s.native_comp_u = comp_u;
@@ -5467,12 +5463,15 @@ This gets called by top_level_run during the load phase. */)
{
Lisp_Object doc_idx = FIRST (rest);
Lisp_Object intspec = SECOND (rest);
+ Lisp_Object command_modes = THIRD (rest);
+
struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
if (cu->loaded_once)
return Qnil;
Lisp_Object tem =
- make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u);
+ make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec,
+ command_modes, comp_u);
/* We must protect it against GC because the function is not
reachable through symbols. */
@@ -5497,9 +5496,11 @@ This gets called by top_level_run during the load phase. */)
{
Lisp_Object doc_idx = FIRST (rest);
Lisp_Object intspec = SECOND (rest);
+ Lisp_Object command_modes = THIRD (rest);
+
Lisp_Object tem =
make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx,
- intspec, comp_u);
+ intspec, command_modes, comp_u);
defalias (name, tem);
diff --git a/src/comp.h b/src/comp.h
index 40f1e9b979c..da53f32971e 100644
--- a/src/comp.h
+++ b/src/comp.h
@@ -53,6 +53,8 @@ struct Lisp_Native_Comp_Unit
#ifdef HAVE_NATIVE_COMP
+INLINE_HEADER_BEGIN
+
INLINE bool
NATIVE_COMP_UNITP (Lisp_Object a)
{
@@ -99,6 +101,8 @@ void unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
extern void syms_of_comp (void);
+INLINE_HEADER_END
+
#endif /* #ifdef HAVE_NATIVE_COMP */
#endif /* #ifndef COMP_H */
diff --git a/src/data.c b/src/data.c
index 1526cc0c737..f06b561dcc6 100644
--- a/src/data.c
+++ b/src/data.c
@@ -1167,7 +1167,11 @@ The value, if non-nil, is a list of mode name symbols. */)
fun = Fsymbol_function (fun);
}
- if (COMPILEDP (fun))
+ if (SUBRP (fun))
+ {
+ return XSUBR (fun)->command_modes;
+ }
+ else if (COMPILEDP (fun))
{
if (PVSIZE (fun) <= COMPILED_INTERACTIVE)
return Qnil;
@@ -2813,6 +2817,9 @@ DEFUN ("<", Flss, Slss, 1, MANY, 0,
usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
+ if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
+ return XFIXNUM (args[0]) < XFIXNUM (args[1]) ? Qt : Qnil;
+
return arithcompare_driver (nargs, args, ARITH_LESS);
}
@@ -2821,6 +2828,9 @@ DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
+ if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
+ return XFIXNUM (args[0]) > XFIXNUM (args[1]) ? Qt : Qnil;
+
return arithcompare_driver (nargs, args, ARITH_GRTR);
}
@@ -2829,6 +2839,9 @@ DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
+ if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
+ return XFIXNUM (args[0]) <= XFIXNUM (args[1]) ? Qt : Qnil;
+
return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
}
@@ -2837,6 +2850,9 @@ DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
+ if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
+ return XFIXNUM (args[0]) >= XFIXNUM (args[1]) ? Qt : Qnil;
+
return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
}
@@ -2968,6 +2984,29 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
return val;
}
+/* Render NUMBER in decimal into BUFFER which ends right before END.
+ Return the start of the string; the end is always at END.
+ The string is not null-terminated. */
+char *
+fixnum_to_string (EMACS_INT number, char *buffer, char *end)
+{
+ EMACS_INT x = number;
+ bool negative = x < 0;
+ if (negative)
+ x = -x;
+ char *p = end;
+ do
+ {
+ eassume (p > buffer && p - 1 < end);
+ *--p = '0' + x % 10;
+ x /= 10;
+ }
+ while (x);
+ if (negative)
+ *--p = '-';
+ return p;
+}
+
DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
doc: /* Return the decimal representation of NUMBER as a string.
Uses a minus sign if negative.
@@ -2975,19 +3014,22 @@ NUMBER may be an integer or a floating point number. */)
(Lisp_Object number)
{
char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
- int len;
- CHECK_NUMBER (number);
+ if (FIXNUMP (number))
+ {
+ char *end = buffer + sizeof buffer;
+ char *p = fixnum_to_string (XFIXNUM (number), buffer, end);
+ return make_unibyte_string (p, end - p);
+ }
if (BIGNUMP (number))
return bignum_to_string (number, 10);
if (FLOATP (number))
- len = float_to_string (buffer, XFLOAT_DATA (number));
- else
- len = sprintf (buffer, "%"pI"d", XFIXNUM (number));
+ return make_unibyte_string (buffer,
+ float_to_string (buffer, XFLOAT_DATA (number)));
- return make_unibyte_string (buffer, len);
+ wrong_type_argument (Qnumberp, number);
}
DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
diff --git a/src/decompress.c b/src/decompress.c
index ddd8abbf27c..dbdc9104a37 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -67,8 +67,9 @@ init_zlib_functions (void)
#endif /* WINDOWSNT */
+#ifdef HAVE_NATIVE_COMP
-#define MD5_BLOCKSIZE 32768 /* From md5.c */
+# define MD5_BLOCKSIZE 32768 /* From md5.c */
static char acc_buff[2 * MD5_BLOCKSIZE];
static size_t acc_size;
@@ -106,7 +107,7 @@ md5_gz_stream (FILE *source, void *resblock)
unsigned char in[MD5_BLOCKSIZE];
unsigned char out[MD5_BLOCKSIZE];
-#ifdef WINDOWSNT
+# ifdef WINDOWSNT
if (!zlib_initialized)
zlib_initialized = init_zlib_functions ();
if (!zlib_initialized)
@@ -114,7 +115,7 @@ md5_gz_stream (FILE *source, void *resblock)
message1 ("zlib library not found");
return -1;
}
-#endif
+# endif
eassert (!acc_size);
@@ -164,7 +165,8 @@ md5_gz_stream (FILE *source, void *resblock)
return 0;
}
-#undef MD5_BLOCKSIZE
+# undef MD5_BLOCKSIZE
+#endif
diff --git a/src/deps.mk b/src/deps.mk
index deffab93eca..39edd5c1dd3 100644
--- a/src/deps.mk
+++ b/src/deps.mk
@@ -279,7 +279,7 @@ eval.o: eval.c commands.h keyboard.h blockinput.h atimer.h systime.h frame.h \
dispextern.h lisp.h globals.h $(config_h) coding.h composite.h xterm.h \
msdos.h
floatfns.o: floatfns.c syssignal.h lisp.h globals.h $(config_h)
-fns.o: fns.c commands.h lisp.h $(config_h) frame.h buffer.h character.h \
+fns.o: fns.c sort.c commands.h lisp.h $(config_h) frame.h buffer.h character.h \
keyboard.h keymap.h window.h $(INTERVALS_H) coding.h ../lib/md5.h \
../lib/sha1.h ../lib/sha256.h ../lib/sha512.h blockinput.h atimer.h \
systime.h xterm.h ../lib/unistd.h globals.h
diff --git a/src/dispextern.h b/src/dispextern.h
index b7cfde70339..e9b19a7f135 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -3460,6 +3460,8 @@ extern Lisp_Object handle_tab_bar_click (struct frame *,
int, int, bool, int);
extern void handle_tool_bar_click (struct frame *,
int, int, bool, int);
+extern void handle_tool_bar_click_with_device (struct frame *, int, int, bool,
+ int, Lisp_Object);
extern void expose_frame (struct frame *, int, int, int, int);
extern bool gui_intersect_rectangles (const Emacs_Rectangle *,
diff --git a/src/doc.c b/src/doc.c
index a9f77b25bfa..5326195c6a0 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -341,56 +341,8 @@ string is passed through `substitute-command-keys'. */)
else if (MODULE_FUNCTIONP (fun))
doc = module_function_documentation (XMODULE_FUNCTION (fun));
#endif
- else if (COMPILEDP (fun))
- {
- if (PVSIZE (fun) <= COMPILED_DOC_STRING)
- return Qnil;
- else
- {
- Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
- if (STRINGP (tem))
- doc = tem;
- else if (FIXNATP (tem) || CONSP (tem))
- doc = tem;
- else
- return Qnil;
- }
- }
- else if (STRINGP (fun) || VECTORP (fun))
- {
- return build_string ("Keyboard macro.");
- }
- else if (CONSP (fun))
- {
- Lisp_Object funcar = XCAR (fun);
- if (!SYMBOLP (funcar))
- xsignal1 (Qinvalid_function, fun);
- else if (EQ (funcar, Qkeymap))
- return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
- else if (EQ (funcar, Qlambda)
- || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
- || EQ (funcar, Qautoload))
- {
- Lisp_Object tem1 = Fcdr (Fcdr (fun));
- Lisp_Object tem = Fcar (tem1);
- if (STRINGP (tem))
- doc = tem;
- /* Handle a doc reference--but these never come last
- in the function body, so reject them if they are last. */
- else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem))))
- && !NILP (XCDR (tem1)))
- doc = tem;
- else
- return Qnil;
- }
- else
- goto oops;
- }
else
- {
- oops:
- xsignal1 (Qinvalid_function, fun);
- }
+ doc = call1 (intern ("function-documentation"), fun);
/* If DOC is 0, it's typically because of a dumped file missing
from the DOC file (bug in src/Makefile.in). */
@@ -514,11 +466,19 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
{
/* This bytecode object must have a slot for the
docstring, since we've found a docstring for it. */
- if (PVSIZE (fun) > COMPILED_DOC_STRING)
+ if (PVSIZE (fun) > COMPILED_DOC_STRING
+ /* Don't overwrite a non-docstring value placed there,
+ * such as the symbols used for Oclosures. */
+ && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING))
+ || STRINGP (AREF (fun, COMPILED_DOC_STRING))
+ || CONSP (AREF (fun, COMPILED_DOC_STRING))))
ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
else
{
- AUTO_STRING (format, "No docstring slot for %s");
+ AUTO_STRING (format,
+ (PVSIZE (fun) > COMPILED_DOC_STRING
+ ? "Docstring slot busy for %s"
+ : "No docstring slot for %s"));
CALLN (Fmessage, format,
(SYMBOLP (obj)
? SYMBOL_NAME (obj)
diff --git a/src/dynlib.c b/src/dynlib.c
index 8cb9a233745..e2c71f14489 100644
--- a/src/dynlib.c
+++ b/src/dynlib.c
@@ -279,11 +279,13 @@ dynlib_open (const char *path)
return dlopen (path, RTLD_LAZY | RTLD_GLOBAL);
}
+# ifdef HAVE_NATIVE_COMP
dynlib_handle_ptr
dynlib_open_for_eln (const char *path)
{
return dlopen (path, RTLD_LAZY);
}
+# endif
void *
dynlib_sym (dynlib_handle_ptr h, const char *sym)
@@ -313,11 +315,13 @@ dynlib_error (void)
return dlerror ();
}
+# ifdef HAVE_NATIVE_COMP
int
dynlib_close (dynlib_handle_ptr h)
{
return dlclose (h) == 0;
}
+# endif
#else
diff --git a/src/emacs.c b/src/emacs.c
index d1060bca0b3..a35996c07aa 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -140,6 +140,10 @@ extern char etext;
#include "fingerprint.h"
#include "epaths.h"
+/* Include these only because of INLINE. */
+#include "comp.h"
+#include "thread.h"
+
static const char emacs_version[] = PACKAGE_VERSION;
static const char emacs_copyright[] = COPYRIGHT;
static const char emacs_bugreport[] = PACKAGE_BUGREPORT;
@@ -1730,12 +1734,25 @@ main (int argc, char **argv)
sockfd = SD_LISTEN_FDS_START;
#endif /* HAVE_LIBSYSTEMD */
-#ifdef USE_GTK
+ /* On X, the bug happens because we call abort to avoid GLib
+ crashes upon a longjmp in our X error handler.
+
+ On PGTK, GTK calls exit in its own error handlers for either
+ X or Wayland. Display different messages depending on the
+ window system to avoid referring users to the wrong GTK bug
+ report. */
+#ifdef HAVE_PGTK
+ fputs ("Due to a limitation in GTK 3, Emacs built with PGTK will simply exit when a\n"
+ "display connection is closed. The problem is especially difficult to fix,\n"
+ "such that Emacs on Wayland with multiple displays is unlikely ever to be able\n"
+ "to survive disconnects.\n",
+ stderr);
+#elif defined USE_GTK
fputs ("\nWarning: due to a long standing Gtk+ bug\nhttps://gitlab.gnome.org/GNOME/gtk/issues/221\n\
Emacs might crash when run in daemon mode and the X11 connection is unexpectedly lost.\n\
Using an Emacs configured with --with-x-toolkit=lucid does not have this problem.\n",
stderr);
-#endif /* USE_GTK */
+#endif
if (daemon_type == 2)
{
@@ -2814,9 +2831,6 @@ shut_down_emacs (int sig, Lisp_Object stuff)
/* Don't update display from now on. */
Vinhibit_redisplay = Qt;
-#ifdef HAVE_HAIKU
- be_app_quit ();
-#endif
/* If we are controlling the terminal, reset terminal modes. */
#ifndef DOS_NT
pid_t tpgrp = tcgetpgrp (STDIN_FILENO);
diff --git a/src/eval.c b/src/eval.c
index c46b74ac40c..a1cebcd0257 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -559,6 +559,10 @@ usage: (function ARG) */)
{ /* Handle the special (:documentation <form>) to build the docstring
dynamically. */
Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp)));
+ if (SYMBOLP (docstring) && !NILP (docstring))
+ /* Hack for OClosures: Allow the docstring to be a symbol
+ * (the OClosure's type). */
+ docstring = Fsymbol_name (docstring);
CHECK_STRING (docstring);
cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
}
@@ -1501,90 +1505,6 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
}
}
-/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as
- its arguments. */
-
-Lisp_Object
-internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
- Lisp_Object),
- Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
- Lisp_Object handlers,
- Lisp_Object (*hfun) (Lisp_Object))
-{
- struct handler *c = push_handler (handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return hfun (val);
- }
- else
- {
- Lisp_Object val = bfun (arg1, arg2, arg3);
- eassert (handlerlist == c);
- handlerlist = c->next;
- return val;
- }
-}
-
-/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as
- its arguments. */
-
-Lisp_Object
-internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object arg1, Lisp_Object arg2,
- Lisp_Object arg3, Lisp_Object arg4,
- Lisp_Object handlers,
- Lisp_Object (*hfun) (Lisp_Object))
-{
- struct handler *c = push_handler (handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return hfun (val);
- }
- else
- {
- Lisp_Object val = bfun (arg1, arg2, arg3, arg4);
- eassert (handlerlist == c);
- handlerlist = c->next;
- return val;
- }
-}
-
-/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3,
- ARG4, ARG5 as its arguments. */
-
-Lisp_Object
-internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object,
- Lisp_Object),
- Lisp_Object arg1, Lisp_Object arg2,
- Lisp_Object arg3, Lisp_Object arg4,
- Lisp_Object arg5, Lisp_Object handlers,
- Lisp_Object (*hfun) (Lisp_Object))
-{
- struct handler *c = push_handler (handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return hfun (val);
- }
- else
- {
- Lisp_Object val = bfun (arg1, arg2, arg3, arg4, arg5);
- eassert (handlerlist == c);
- handlerlist = c->next;
- return val;
- }
-}
-
/* Like internal_condition_case but call BFUN with NARGS as first,
and ARGS as second argument. */
@@ -2846,76 +2766,6 @@ apply1 (Lisp_Object fn, Lisp_Object arg)
return NILP (arg) ? Ffuncall (1, &fn) : CALLN (Fapply, fn, arg);
}
-/* Call function fn on no arguments. */
-Lisp_Object
-call0 (Lisp_Object fn)
-{
- return Ffuncall (1, &fn);
-}
-
-/* Call function fn with 1 argument arg1. */
-Lisp_Object
-call1 (Lisp_Object fn, Lisp_Object arg1)
-{
- return CALLN (Ffuncall, fn, arg1);
-}
-
-/* Call function fn with 2 arguments arg1, arg2. */
-Lisp_Object
-call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
-{
- return CALLN (Ffuncall, fn, arg1, arg2);
-}
-
-/* Call function fn with 3 arguments arg1, arg2, arg3. */
-Lisp_Object
-call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
-{
- return CALLN (Ffuncall, fn, arg1, arg2, arg3);
-}
-
-/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
-Lisp_Object
-call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
- Lisp_Object arg4)
-{
- return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4);
-}
-
-/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
-Lisp_Object
-call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
- Lisp_Object arg4, Lisp_Object arg5)
-{
- return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5);
-}
-
-/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
-Lisp_Object
-call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
- Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
-{
- return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6);
-}
-
-/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
-Lisp_Object
-call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
- Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7)
-{
- return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7);
-}
-
-/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
- arg6, arg7, arg8. */
-Lisp_Object
-call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
- Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7,
- Lisp_Object arg8)
-{
- return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
-}
-
DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
doc: /* Return t if OBJECT is a function. */)
(Lisp_Object object)
@@ -3576,6 +3426,20 @@ record_unwind_protect_ptr (void (*function) (void *), void *arg)
specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
specpdl_ptr->unwind_ptr.func = function;
specpdl_ptr->unwind_ptr.arg = arg;
+ specpdl_ptr->unwind_ptr.mark = NULL;
+ grow_specpdl ();
+}
+
+/* Like `record_unwind_protect_ptr', but also specifies a function
+ for GC-marking Lisp objects only reachable through ARG. */
+void
+record_unwind_protect_ptr_mark (void (*function) (void *), void *arg,
+ void (*mark) (void *))
+{
+ specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
+ specpdl_ptr->unwind_ptr.func = function;
+ specpdl_ptr->unwind_ptr.arg = arg;
+ specpdl_ptr->unwind_ptr.mark = mark;
grow_specpdl ();
}
@@ -3619,6 +3483,7 @@ record_unwind_protect_module (enum specbind_tag kind, void *ptr)
specpdl_ptr->kind = kind;
specpdl_ptr->unwind_ptr.func = NULL;
specpdl_ptr->unwind_ptr.arg = ptr;
+ specpdl_ptr->unwind_ptr.mark = NULL;
grow_specpdl ();
}
@@ -3747,6 +3612,7 @@ set_unwind_protect_ptr (specpdl_ref count, void (*func) (void *), void *arg)
p->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
p->unwind_ptr.func = func;
p->unwind_ptr.arg = arg;
+ p->unwind_ptr.mark = NULL;
}
/* Pop and execute entries from the unwind-protect stack until the
@@ -4180,6 +4046,10 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
break;
case SPECPDL_UNWIND_PTR:
+ if (pdl->unwind_ptr.mark)
+ pdl->unwind_ptr.mark (pdl->unwind_ptr.arg);
+ break;
+
case SPECPDL_UNWIND_INT:
case SPECPDL_UNWIND_INTMAX:
case SPECPDL_UNWIND_VOID:
diff --git a/src/fileio.c b/src/fileio.c
index a0282204de8..c418036fc6e 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -2505,6 +2505,8 @@ With a prefix argument, TRASH is nil. */)
return Qnil;
}
+#if defined HAVE_NATIVE_COMP && defined WINDOWSNT
+
static Lisp_Object
internal_delete_file_1 (Lisp_Object ignore)
{
@@ -2523,6 +2525,8 @@ internal_delete_file (Lisp_Object filename)
Qt, internal_delete_file_1);
return NILP (tem);
}
+
+#endif
/* Return -1 if FILE is a case-insensitive file name, 0 if not,
and a positive errno value if the result cannot be determined. */
@@ -5519,7 +5523,10 @@ DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0,
doc: /* Return t if (car A) is numerically less than (car B). */)
(Lisp_Object a, Lisp_Object b)
{
- return arithcompare (Fcar (a), Fcar (b), ARITH_LESS);
+ Lisp_Object ca = Fcar (a), cb = Fcar (b);
+ if (FIXNUMP (ca) && FIXNUMP (cb))
+ return XFIXNUM (ca) < XFIXNUM (cb) ? Qt : Qnil;
+ return arithcompare (ca, cb, ARITH_LESS);
}
/* Build the complete list of annotations appropriate for writing out
diff --git a/src/fns.c b/src/fns.c
index 6e89fe3ca5f..4673fde28c7 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -39,9 +39,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "puresize.h"
#include "gnutls.h"
-static void sort_vector_copy (Lisp_Object pred, ptrdiff_t len,
- Lisp_Object src[restrict VLA_ELEMS (len)],
- Lisp_Object dest[restrict VLA_ELEMS (len)]);
enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES };
static bool internal_equal (Lisp_Object, Lisp_Object,
enum equal_kind, int, Lisp_Object);
@@ -444,15 +441,24 @@ Symbols are also allowed; their print names are used instead. */)
{
if (SYMBOLP (string1))
string1 = SYMBOL_NAME (string1);
+ else
+ CHECK_STRING (string1);
if (SYMBOLP (string2))
string2 = SYMBOL_NAME (string2);
- CHECK_STRING (string1);
- CHECK_STRING (string2);
+ else
+ CHECK_STRING (string2);
+
+ ptrdiff_t n = min (SCHARS (string1), SCHARS (string2));
+ if (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2))
+ {
+ /* Both arguments are unibyte (hot path). */
+ int d = memcmp (SSDATA (string1), SSDATA (string2), n);
+ return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil;
+ }
ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0, i2_byte = 0;
- ptrdiff_t end = min (SCHARS (string1), SCHARS (string2));
- while (i1 < end)
+ while (i1 < n)
{
/* When we find a mismatch, we must compare the
characters, not just the bytes. */
@@ -485,37 +491,9 @@ Symbols are also allowed; their print names are used instead. */)
string2 = SYMBOL_NAME (string2);
CHECK_STRING (string1);
CHECK_STRING (string2);
- return string_version_cmp (string1, string2) < 0 ? Qt : Qnil;
-}
-
-/* Return negative, 0, positive if STRING1 is <, =, > STRING2 as per
- string-version-lessp. */
-int
-string_version_cmp (Lisp_Object string1, Lisp_Object string2)
-{
- char *p1 = SSDATA (string1);
- char *p2 = SSDATA (string2);
- char *lim1 = p1 + SBYTES (string1);
- char *lim2 = p2 + SBYTES (string2);
- int cmp;
-
- while ((cmp = filevercmp (p1, p2)) == 0)
- {
- /* If the strings are identical through their first null bytes,
- skip past identical prefixes and try again. */
- ptrdiff_t size = strlen (p1) + 1;
- eassert (size == strlen (p2) + 1);
- p1 += size;
- p2 += size;
- bool more1 = p1 <= lim1;
- bool more2 = p2 <= lim2;
- if (!more1)
- return more2;
- if (!more2)
- return -1;
- }
-
- return cmp;
+ int cmp = filenvercmp (SSDATA (string1), SBYTES (string1),
+ SSDATA (string2), SBYTES (string2));
+ return cmp < 0 ? Qt : Qnil;
}
DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
@@ -2135,8 +2113,11 @@ See also the function `nreverse', which is used more often. */)
return new;
}
-/* Sort LIST using PREDICATE, preserving original order of elements
- considered as equal. */
+
+/* Stably sort LIST ordered by PREDICATE using the TIMSORT
+ algorithm. This converts the list to a vector, sorts the vector,
+ and returns the result converted back to a list. The input list is
+ destructively reused to hold the sorted result. */
static Lisp_Object
sort_list (Lisp_Object list, Lisp_Object predicate)
@@ -2144,112 +2125,43 @@ sort_list (Lisp_Object list, Lisp_Object predicate)
ptrdiff_t length = list_length (list);
if (length < 2)
return list;
-
- Lisp_Object tem = Fnthcdr (make_fixnum (length / 2 - 1), list);
- Lisp_Object back = Fcdr (tem);
- Fsetcdr (tem, Qnil);
-
- return merge (Fsort (list, predicate), Fsort (back, predicate), predicate);
-}
-
-/* Using PRED to compare, return whether A and B are in order.
- Compare stably when A appeared before B in the input. */
-static bool
-inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b)
-{
- return NILP (call2 (pred, b, a));
-}
-
-/* Using PRED to compare, merge from ALEN-length A and BLEN-length B
- into DEST. Argument arrays must be nonempty and must not overlap,
- except that B might be the last part of DEST. */
-static void
-merge_vectors (Lisp_Object pred,
- ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)],
- ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)],
- Lisp_Object dest[VLA_ELEMS (alen + blen)])
-{
- eassume (0 < alen && 0 < blen);
- Lisp_Object const *alim = a + alen;
- Lisp_Object const *blim = b + blen;
-
- while (true)
+ else
{
- if (inorder (pred, a[0], b[0]))
+ Lisp_Object *result;
+ USE_SAFE_ALLOCA;
+ SAFE_ALLOCA_LISP (result, length);
+ Lisp_Object tail = list;
+ for (ptrdiff_t i = 0; i < length; i++)
{
- *dest++ = *a++;
- if (a == alim)
- {
- if (dest != b)
- memcpy (dest, b, (blim - b) * sizeof *dest);
- return;
- }
+ result[i] = Fcar (tail);
+ tail = XCDR (tail);
}
- else
+ tim_sort (predicate, result, length);
+
+ ptrdiff_t i = 0;
+ tail = list;
+ while (CONSP (tail))
{
- *dest++ = *b++;
- if (b == blim)
- {
- memcpy (dest, a, (alim - a) * sizeof *dest);
- return;
- }
+ XSETCAR (tail, result[i]);
+ tail = XCDR (tail);
+ i++;
}
+ SAFE_FREE ();
+ return list;
}
}
-/* Using PRED to compare, sort LEN-length VEC in place, using TMP for
- temporary storage. LEN must be at least 2. */
-static void
-sort_vector_inplace (Lisp_Object pred, ptrdiff_t len,
- Lisp_Object vec[restrict VLA_ELEMS (len)],
- Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)])
-{
- eassume (2 <= len);
- ptrdiff_t halflen = len >> 1;
- sort_vector_copy (pred, halflen, vec, tmp);
- if (1 < len - halflen)
- sort_vector_inplace (pred, len - halflen, vec + halflen, vec);
- merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec);
-}
-
-/* Using PRED to compare, sort from LEN-length SRC into DST.
- Len must be positive. */
-static void
-sort_vector_copy (Lisp_Object pred, ptrdiff_t len,
- Lisp_Object src[restrict VLA_ELEMS (len)],
- Lisp_Object dest[restrict VLA_ELEMS (len)])
-{
- eassume (0 < len);
- ptrdiff_t halflen = len >> 1;
- if (halflen < 1)
- dest[0] = src[0];
- else
- {
- if (1 < halflen)
- sort_vector_inplace (pred, halflen, src, dest);
- if (1 < len - halflen)
- sort_vector_inplace (pred, len - halflen, src + halflen, dest);
- merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest);
- }
-}
-
-/* Sort VECTOR in place using PREDICATE, preserving original order of
- elements considered as equal. */
+/* Stably sort VECTOR ordered by PREDICATE using the TIMSORT
+ algorithm. */
static void
sort_vector (Lisp_Object vector, Lisp_Object predicate)
{
- ptrdiff_t len = ASIZE (vector);
- if (len < 2)
+ ptrdiff_t length = ASIZE (vector);
+ if (length < 2)
return;
- ptrdiff_t halflen = len >> 1;
- Lisp_Object *tmp;
- USE_SAFE_ALLOCA;
- SAFE_ALLOCA_LISP (tmp, halflen);
- for (ptrdiff_t i = 0; i < halflen; i++)
- tmp[i] = make_fixnum (0);
- sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
- SAFE_FREE ();
+
+ tim_sort (predicate, XVECTOR (vector)->contents, length);
}
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
@@ -2295,7 +2207,7 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
}
Lisp_Object tem;
- if (inorder (pred, Fcar (l1), Fcar (l2)))
+ if (!NILP (call2 (pred, Fcar (l1), Fcar (l2))))
{
tem = l1;
l1 = Fcdr (l1);
@@ -3003,6 +2915,9 @@ it does up to one space will be removed.
The user must confirm the answer with RET, and can edit it until it
has been confirmed.
+If the `use-short-answers' variable is non-nil, instead of asking for
+\"yes\" or \"no\", this function will ask for \"y\" or \"n\".
+
If dialog boxes are supported, a dialog box will be used
if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
(Lisp_Object prompt)
@@ -4242,7 +4157,7 @@ hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h)
/* Ignore HT and return a hash code for KEY which uses 'equal' to compare keys.
The hash code is at most INTMASK. */
-Lisp_Object
+static Lisp_Object
hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h)
{
return make_ufixnum (sxhash (key));
@@ -4251,7 +4166,7 @@ hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h)
/* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys.
The hash code is at most INTMASK. */
-Lisp_Object
+static Lisp_Object
hashfn_eql (Lisp_Object key, struct Lisp_Hash_Table *h)
{
return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, h);
diff --git a/src/frame.c b/src/frame.c
index 0ec7057db20..93028aa8958 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -335,7 +335,7 @@ DEFUN ("frame-windows-min-size", Fframe_windows_min_size,
* additionally limit the minimum frame height to a value large enough
* to support menu bar, tab bar, mode line and echo area.
*/
-int
+static int
frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal,
Lisp_Object ignore, Lisp_Object pixelwise)
{
@@ -1987,6 +1987,14 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
else
error ("Attempt to delete the only frame");
}
+#ifdef HAVE_X_WINDOWS
+ else if (x_dnd_in_progress && f == x_dnd_frame)
+ error ("Attempt to delete the drop source frame");
+#endif
+#ifdef HAVE_HAIKU
+ else if (f == haiku_dnd_frame)
+ error ("Attempt to delete the drop source frame");
+#endif
XSETFRAME (frame, f);
@@ -2505,9 +2513,12 @@ vertical offset, measured in units of the frame's default character size.
If Emacs is running on a mouseless terminal or hasn't been programmed
to read the mouse position, it returns the selected frame for FRAME
and nil for X and Y.
-If `mouse-position-function' is non-nil, `mouse-position' calls it,
-passing the normal return value to that function as an argument,
-and returns whatever that function returns. */)
+
+FRAME might be nil if `track-mouse' is set to `drag-source'. This
+means there is no frame under the mouse. If `mouse-position-function'
+is non-nil, `mouse-position' calls it, passing the normal return value
+to that function as an argument, and returns whatever that function
+returns. */)
(void)
{
return mouse_position (true);
@@ -2534,7 +2545,7 @@ mouse_position (bool call_mouse_position_function)
&time_dummy);
}
- if (! NILP (x))
+ if (! NILP (x) && f)
{
int col = XFIXNUM (x);
int row = XFIXNUM (y);
@@ -2542,7 +2553,10 @@ mouse_position (bool call_mouse_position_function)
XSETINT (x, col);
XSETINT (y, row);
}
- XSETFRAME (lispy_dummy, f);
+ if (f)
+ XSETFRAME (lispy_dummy, f);
+ else
+ lispy_dummy = Qnil;
retval = Fcons (lispy_dummy, Fcons (x, y));
if (call_mouse_position_function && !NILP (Vmouse_position_function))
retval = call1 (Vmouse_position_function, retval);
@@ -2555,9 +2569,11 @@ DEFUN ("mouse-pixel-position", Fmouse_pixel_position,
The position is given in pixel units, where (0, 0) is the
upper-left corner of the frame, X is the horizontal offset, and Y is
the vertical offset.
-If Emacs is running on a mouseless terminal or hasn't been programmed
-to read the mouse position, it returns the selected frame for FRAME
-and nil for X and Y. */)
+FRAME might be nil if `track-mouse' is set to `drag-source'. This
+means there is no frame under the mouse. If Emacs is running on a
+mouseless terminal or hasn't been programmed to read the mouse
+position, it returns the selected frame for FRAME and nil for X and
+Y. */)
(void)
{
struct frame *f;
@@ -2578,7 +2594,11 @@ and nil for X and Y. */)
&time_dummy);
}
- XSETFRAME (lispy_dummy, f);
+ if (f)
+ XSETFRAME (lispy_dummy, f);
+ else
+ lispy_dummy = Qnil;
+
retval = Fcons (lispy_dummy, Fcons (x, y));
if (!NILP (Vmouse_position_function))
retval = call1 (Vmouse_position_function, retval);
@@ -3495,7 +3515,10 @@ DEFUN ("frame-native-width", Fframe_native_width,
Sframe_native_width, 0, 1, 0,
doc: /* Return FRAME's native width in pixels.
For a terminal frame, the result really gives the width in characters.
-If FRAME is omitted or nil, the selected frame is used. */)
+If FRAME is omitted or nil, the selected frame is used.
+
+If you're interested only in the width of the text portion of the
+frame, see `frame-text-width' instead. */)
(Lisp_Object frame)
{
struct frame *f = decode_any_frame (frame);
@@ -3519,6 +3542,9 @@ minibuffer or echo area), mode line, and header line. It does not
include the tool bar or menu bar. With other graphical versions, it may
also include the tool bar and the menu bar.
+If you're interested only in the height of the text portion of the
+frame, see `frame-text-height' instead.
+
For a text terminal, it includes the menu bar. In this case, the
result is really in characters rather than pixels (i.e., is identical
to `frame-height'). */)
diff --git a/src/frame.h b/src/frame.h
index 5d5f2122fbb..4942e640d27 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -102,6 +102,10 @@ struct frame
Lisp_Object parent_frame;
#endif /* HAVE_WINDOW_SYSTEM */
+ /* Last device to move over this frame. Any value that isn't a
+ string means the "Virtual core pointer". */
+ Lisp_Object last_mouse_device;
+
/* The frame which should receive keystrokes that occur in this
frame, or nil if they should go to the frame itself. This is
usually nil, but if the frame is minibufferless, we can use this
@@ -1338,8 +1342,6 @@ extern bool frame_inhibit_resize (struct frame *, bool, Lisp_Object);
extern void adjust_frame_size (struct frame *, int, int, int, bool,
Lisp_Object);
extern Lisp_Object mouse_position (bool);
-extern int frame_windows_min_size (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object);
extern void frame_size_history_plain (struct frame *, Lisp_Object);
extern void frame_size_history_extra (struct frame *, Lisp_Object,
int, int, int, int, int, int);
diff --git a/src/gnutls.c b/src/gnutls.c
index 09590ca005c..0e1e63e157a 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -1521,7 +1521,7 @@ returned as the :certificate entry. */)
/* Initialize global GnuTLS state to defaults.
Call 'gnutls-global-deinit' when GnuTLS usage is no longer needed.
Return zero on success. */
-Lisp_Object
+static Lisp_Object
emacs_gnutls_global_init (void)
{
int ret = GNUTLS_E_SUCCESS;
diff --git a/src/gnutls.h b/src/gnutls.h
index 791e5340c2d..19d3d3f5bc6 100644
--- a/src/gnutls.h
+++ b/src/gnutls.h
@@ -90,7 +90,6 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err);
extern int w32_gnutls_rnd (gnutls_rnd_level_t, void *, size_t);
#endif
extern Lisp_Object emacs_gnutls_deinit (Lisp_Object);
-extern Lisp_Object emacs_gnutls_global_init (void);
extern int gnutls_try_handshake (struct Lisp_Process *p);
extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist);
diff --git a/src/gtkutil.c b/src/gtkutil.c
index ec2864e34a7..718da171f49 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -6274,6 +6274,10 @@ xg_im_context_commit (GtkIMContext *imc, gchar *str,
{
struct frame *f = user_data;
struct input_event ie;
+#ifdef HAVE_XINPUT2
+ struct xi_device_t *source;
+ struct x_display_info *dpyinfo;
+#endif
EVENT_INIT (ie);
/* This used to use g_utf8_to_ucs4_fast, which led to bad results
@@ -6292,6 +6296,22 @@ xg_im_context_commit (GtkIMContext *imc, gchar *str,
make_fixnum (SCHARS (ie.arg)),
Qcoding, Qt, ie.arg);
+#ifdef HAVE_XINPUT2
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ /* There is no timestamp associated with commit events, so use the
+ device that sent the last event to be filtered. */
+ if (dpyinfo->pending_keystroke_time)
+ {
+ dpyinfo->pending_keystroke_time = 0;
+ source = xi_device_from_id (dpyinfo,
+ dpyinfo->pending_keystroke_source);
+
+ if (source)
+ ie.device = source->name;
+ }
+#endif
+
XSETFRAME (ie.frame_or_window, f);
ie.modifiers = 0;
ie.timestamp = 0;
@@ -6347,6 +6367,10 @@ xg_widget_key_press_event_cb (GtkWidget *widget, GdkEvent *event,
guint keysym = event->key.keyval;
unsigned int xstate;
gunichar uc;
+#ifdef HAVE_XINPUT2
+ Time pending_keystroke_time;
+ struct xi_device_t *source;
+#endif
FOR_EACH_FRAME (tail, tem)
{
@@ -6361,6 +6385,14 @@ xg_widget_key_press_event_cb (GtkWidget *widget, GdkEvent *event,
if (!f)
return true;
+#ifdef HAVE_XINPUT2
+ pending_keystroke_time
+ = FRAME_DISPLAY_INFO (f)->pending_keystroke_time;
+
+ if (event->key.time >= pending_keystroke_time)
+ FRAME_DISPLAY_INFO (f)->pending_keystroke_time = 0;
+#endif
+
if (!x_gtk_use_native_input
&& !FRAME_DISPLAY_INFO (f)->prefer_native_input)
return true;
@@ -6375,6 +6407,17 @@ xg_widget_key_press_event_cb (GtkWidget *widget, GdkEvent *event,
|= x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), xstate);
inev.ie.timestamp = event->key.time;
+#ifdef HAVE_XINPUT2
+ if (event->key.time == pending_keystroke_time)
+ {
+ source = xi_device_from_id (FRAME_DISPLAY_INFO (f),
+ FRAME_DISPLAY_INFO (f)->pending_keystroke_source);
+
+ if (source)
+ inev.ie.device = source->name;
+ }
+#endif
+
if (event->key.is_modifier)
goto done;
diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc
index 549c54d8649..fd41ee71f04 100644
--- a/src/haiku_font_support.cc
+++ b/src/haiku_font_support.cc
@@ -289,6 +289,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern)
pattern->specified |= FSPEC_STYLE;
std::strncpy ((char *) &pattern->style, st,
sizeof pattern->style - 1);
+ pattern->style[sizeof pattern->style - 1] = '\0';
}
free (style);
@@ -411,6 +412,7 @@ haiku_font_fill_pattern (struct haiku_font_pattern *pattern,
pattern->specified |= FSPEC_FAMILY;
std::strncpy (pattern->family, family,
sizeof pattern->family - 1);
+ pattern->family[sizeof pattern->family - 1] = '\0';
pattern->specified |= FSPEC_SPACING;
pattern->mono_spacing_p = flags & B_IS_FIXED;
}
@@ -534,6 +536,8 @@ BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size)
if (!(pat->specified & FSPEC_FAMILY))
return 1;
strncpy (name, pat->family, sizeof name - 1);
+ name[sizeof name - 1] = '\0';
+
sty_count = count_font_styles (name);
if (!sty_count &&
@@ -603,6 +607,7 @@ BFont_populate_fixed_family (struct haiku_font_pattern *ptn)
ptn->specified |= FSPEC_FAMILY;
strncpy (ptn->family, f, sizeof ptn->family - 1);
+ ptn->family[sizeof ptn->family - 1] = '\0';
}
void
@@ -614,6 +619,7 @@ BFont_populate_plain_family (struct haiku_font_pattern *ptn)
ptn->specified |= FSPEC_FAMILY;
strncpy (ptn->family, f, sizeof ptn->family - 1);
+ ptn->family[sizeof ptn->family - 1] = '\0';
}
int
diff --git a/src/haiku_select.cc b/src/haiku_select.cc
index 4212f60a480..be8026b6a16 100644
--- a/src/haiku_select.cc
+++ b/src/haiku_select.cc
@@ -28,7 +28,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "haikuselect.h"
-
static BClipboard *primary = NULL;
static BClipboard *secondary = NULL;
static BClipboard *system_clipboard = NULL;
@@ -64,9 +63,17 @@ BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len)
if (len)
*len = bt;
- cb->Unlock ();
+ void *data = malloc (bt);
+
+ if (!data)
+ {
+ cb->Unlock ();
+ return NULL;
+ }
- return strndup (ptr, bt);
+ memcpy (data, ptr, bt);
+ cb->Unlock ();
+ return (char *) data;
}
static void
@@ -311,6 +318,26 @@ be_get_refs_data (void *message, const char *name,
}
int
+be_get_point_data (void *message, const char *name,
+ int32 index, float *x, float *y)
+{
+ status_t rc;
+ BMessage *msg;
+ BPoint point;
+
+ msg = (BMessage *) message;
+ rc = msg->FindPoint (name, index, &point);
+
+ if (rc != B_OK)
+ return 1;
+
+ *x = point.x;
+ *y = point.y;
+
+ return 0;
+}
+
+int
be_get_message_data (void *message, const char *name,
int32 type_code, int32 index,
const void **buf_return,
@@ -322,6 +349,41 @@ be_get_message_data (void *message, const char *name,
index, buf_return, size_return) != B_OK;
}
+uint32
+be_get_message_type (void *message)
+{
+ BMessage *msg = (BMessage *) message;
+
+ return msg->what;
+}
+
+void
+be_set_message_type (void *message, uint32 what)
+{
+ BMessage *msg = (BMessage *) message;
+
+ msg->what = what;
+}
+
+void *
+be_get_message_message (void *message, const char *name,
+ int32 index)
+{
+ BMessage *msg = (BMessage *) message;
+ BMessage *out = new (std::nothrow) BMessage;
+
+ if (!out)
+ return NULL;
+
+ if (msg->FindMessage (name, index, out) != B_OK)
+ {
+ delete out;
+ return NULL;
+ }
+
+ return out;
+}
+
void *
be_create_simple_message (void)
{
@@ -337,3 +399,85 @@ be_add_message_data (void *message, const char *name,
return msg->AddData (name, type_code, buf, buf_size) != B_OK;
}
+
+int
+be_add_refs_data (void *message, const char *name,
+ const char *filename)
+{
+ BEntry entry (filename);
+ entry_ref ref;
+ BMessage *msg = (BMessage *) message;
+
+ if (entry.InitCheck () != B_OK)
+ return 1;
+
+ if (entry.GetRef (&ref) != B_OK)
+ return 1;
+
+ return msg->AddRef (name, &ref) != B_OK;
+}
+
+int
+be_add_point_data (void *message, const char *name,
+ float x, float y)
+{
+ BMessage *msg = (BMessage *) message;
+
+ return msg->AddPoint (name, BPoint (x, y)) != B_OK;
+}
+
+int
+be_add_message_message (void *message, const char *name,
+ void *data)
+{
+ BMessage *msg = (BMessage *) message;
+ BMessage *data_message = (BMessage *) data;
+
+ if (msg->AddMessage (name, data_message) != B_OK)
+ return 1;
+
+ return 0;
+}
+
+int
+be_lock_clipboard_message (enum haiku_clipboard clipboard,
+ void **message_return, bool clear)
+{
+ BClipboard *board;
+
+ if (clipboard == CLIPBOARD_PRIMARY)
+ board = primary;
+ else if (clipboard == CLIPBOARD_SECONDARY)
+ board = secondary;
+ else
+ board = system_clipboard;
+
+ if (!board->Lock ())
+ return 1;
+
+ if (clear)
+ board->Clear ();
+
+ *message_return = board->Data ();
+ return 0;
+}
+
+void
+be_unlock_clipboard (enum haiku_clipboard clipboard, bool discard)
+{
+ BClipboard *board;
+
+ if (clipboard == CLIPBOARD_PRIMARY)
+ board = primary;
+ else if (clipboard == CLIPBOARD_SECONDARY)
+ board = secondary;
+ else
+ board = system_clipboard;
+
+ if (discard)
+ board->Revert ();
+ else
+ board->Commit ();
+
+ board->Unlock ();
+}
diff --git a/src/haiku_support.cc b/src/haiku_support.cc
index 8c45a7adcb1..cb38a572f7c 100644
--- a/src/haiku_support.cc
+++ b/src/haiku_support.cc
@@ -37,6 +37,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <interface/Alert.h>
#include <interface/Button.h>
#include <interface/ControlLook.h>
+#include <interface/Deskbar.h>
#include <locale/UnicodeChar.h>
@@ -80,8 +81,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "haiku_support.h"
-#define SCROLL_BAR_UPDATE 3000
-#define WAIT_FOR_RELEASE 3001
+enum
+ {
+ SCROLL_BAR_UPDATE = 3000,
+ WAIT_FOR_RELEASE = 3001,
+ RELEASE_NOW = 3002,
+ CANCEL_DROP = 3003,
+ };
static color_space dpy_color_space = B_NO_COLOR_SPACE;
static key_map *key_map = NULL;
@@ -117,9 +123,11 @@ static BLocker movement_locker;
static BMessage volatile *popup_track_message;
static int32 volatile alert_popup_value;
+static int current_window_id;
static void *grab_view = NULL;
static BLocker grab_view_locker;
+static bool drag_and_drop_in_progress;
/* This could be a private API, but it's used by (at least) the Qt
port, so it's probably here to stay. */
@@ -402,9 +410,9 @@ public:
BRect pre_zoom_rect;
int x_before_zoom = INT_MIN;
int y_before_zoom = INT_MIN;
- int fullscreen_p = 0;
- int zoomed_p = 0;
- int shown_flag = 0;
+ bool fullscreen_p = false;
+ bool zoomed_p = false;
+ bool shown_flag = false;
volatile int was_shown_p = 0;
bool menu_bar_active_p = false;
bool override_redirect_p = false;
@@ -414,11 +422,16 @@ public:
pthread_mutex_t menu_update_mutex = PTHREAD_MUTEX_INITIALIZER;
pthread_cond_t menu_update_cv = PTHREAD_COND_INITIALIZER;
bool menu_updated_p = false;
+ int window_id;
EmacsWindow () : BWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK,
B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS)
{
+ window_id = current_window_id++;
+ /* This pulse rate is used by scroll bars for repeating a button
+ action while a button is held down. */
+ SetPulseRate (30000);
}
~EmacsWindow ()
@@ -444,6 +457,77 @@ public:
pthread_mutex_destroy (&menu_update_mutex);
}
+ BRect
+ CalculateZoomRect (void)
+ {
+ BScreen screen (this);
+ BDeskbar deskbar;
+ BRect screen_frame;
+ BRect frame;
+ BRect deskbar_frame;
+ BRect window_frame;
+ BRect decorator_frame;
+
+ if (!screen.IsValid ())
+ gui_abort ("Failed to calculate screen rect");
+
+ screen_frame = frame = screen.Frame ();
+ deskbar_frame = deskbar.Frame ();
+
+ if (!(modifiers () & B_SHIFT_KEY)
+ && !deskbar.IsAutoHide ())
+ {
+ switch (deskbar.Location ())
+ {
+ case B_DESKBAR_TOP:
+ frame.top = deskbar_frame.bottom + 2;
+ break;
+
+ case B_DESKBAR_BOTTOM:
+ case B_DESKBAR_LEFT_BOTTOM:
+ case B_DESKBAR_RIGHT_BOTTOM:
+ frame.bottom = deskbar_frame.bottom - 2;
+ break;
+
+ case B_DESKBAR_LEFT_TOP:
+ if (deskbar.IsExpanded ())
+ frame.top = deskbar_frame.bottom + 2;
+ else
+ frame.left = deskbar_frame.right + 2;
+ break;
+
+ default:
+ if (deskbar.IsExpanded ()
+ && !deskbar.IsAlwaysOnTop ()
+ && !deskbar.IsAutoRaise ())
+ frame.right = deskbar_frame.left - 2;
+ }
+ }
+
+ window_frame = Frame ();
+ decorator_frame = DecoratorFrame ();
+
+ frame.top += (window_frame.top
+ - decorator_frame.top);
+ frame.bottom -= (decorator_frame.bottom
+ - window_frame.bottom);
+ frame.left += (window_frame.left
+ - decorator_frame.left);
+ frame.right -= (decorator_frame.right
+ - window_frame.right);
+
+ if (frame.top > deskbar_frame.bottom
+ || frame.bottom < deskbar_frame.top)
+ {
+ frame.left = screen_frame.left + (window_frame.left
+ - decorator_frame.left);
+ frame.right = screen_frame.right - (decorator_frame.right
+ - window_frame.left);
+ }
+
+ return frame;
+ }
+
void
UpwardsSubset (EmacsWindow *w)
{
@@ -639,19 +723,24 @@ public:
if (msg->WasDropped ())
{
BPoint whereto;
+ int32 windowid;
struct haiku_drag_and_drop_event rq;
- if (msg->FindPoint ("_drop_point_", &whereto) == B_OK)
- {
- this->ConvertFromScreen (&whereto);
+ if (msg->FindInt32 ("emacs:window_id", &windowid) == B_OK
+ && !msg->IsSourceRemote ()
+ && windowid == this->window_id)
+ return;
- rq.window = this;
- rq.message = DetachCurrentMessage ();;
- rq.x = whereto.x;
- rq.y = whereto.y;
+ whereto = msg->DropPoint ();
- haiku_write (DRAG_AND_DROP_EVENT, &rq);
- }
+ this->ConvertFromScreen (&whereto);
+
+ rq.window = this;
+ rq.message = DetachCurrentMessage ();
+ rq.x = whereto.x;
+ rq.y = whereto.y;
+
+ haiku_write (DRAG_AND_DROP_EVENT, &rq);
}
else if (msg->GetPointer ("menuptr"))
{
@@ -981,33 +1070,29 @@ public:
Zoom (BPoint o, float w, float h)
{
struct haiku_zoom_event rq;
+ BRect rect;
rq.window = this;
- rq.x = o.x;
- rq.y = o.y;
-
- rq.width = w + 1;
- rq.height = h + 1;
-
if (fullscreen_p)
MakeFullscreen (0);
- if (o.x != x_before_zoom ||
- o.y != y_before_zoom)
+ if (!zoomed_p)
{
- x_before_zoom = Frame ().left;
- y_before_zoom = Frame ().top;
pre_zoom_rect = Frame ();
- zoomed_p = 1;
- haiku_write (ZOOM_EVENT, &rq);
+ zoomed_p = true;
+ rect = CalculateZoomRect ();
}
else
{
- zoomed_p = 0;
- x_before_zoom = y_before_zoom = INT_MIN;
+ zoomed_p = false;
+ rect = pre_zoom_rect;
}
- BWindow::Zoom (o, w, h);
+ rq.zoomed = zoomed_p;
+ haiku_write (ZOOM_EVENT, &rq);
+
+ BWindow::Zoom (rect.LeftTop (), BE_RECT_WIDTH (rect) - 1,
+ BE_RECT_HEIGHT (rect) - 1);
}
void
@@ -1015,11 +1100,8 @@ public:
{
if (!zoomed_p)
return;
- zoomed_p = 0;
- EmacsMoveTo (pre_zoom_rect.left, pre_zoom_rect.top);
- ResizeTo (BE_RECT_WIDTH (pre_zoom_rect) - 1,
- BE_RECT_HEIGHT (pre_zoom_rect) - 1);
+ BWindow::Zoom ();
}
void
@@ -1075,6 +1157,8 @@ public:
if (!screen.IsValid ())
gui_abort ("Trying to make a window fullscreen without a screen");
+ UnZoom ();
+
if (make_fullscreen_p == fullscreen_p)
return;
@@ -1193,7 +1277,10 @@ public:
~EmacsView ()
{
if (wait_for_release_message)
- gui_abort ("Wait for release message still exists");
+ {
+ wait_for_release_message->SendReply (wait_for_release_message);
+ delete wait_for_release_message;
+ }
TearDownDoubleBuffering ();
@@ -1228,6 +1315,14 @@ public:
else
wait_for_release_message = looper->DetachCurrentMessage ();
}
+ else if (msg->what == RELEASE_NOW)
+ {
+ if (wait_for_release_message)
+ wait_for_release_message->SendReply (msg);
+
+ delete wait_for_release_message;
+ wait_for_release_message = NULL;
+ }
else
BView::MessageReceived (msg);
}
@@ -1442,16 +1537,27 @@ public:
}
void
- MouseMoved (BPoint point, uint32 transit, const BMessage *msg)
+ MouseMoved (BPoint point, uint32 transit, const BMessage *drag_msg)
{
struct haiku_mouse_motion_event rq;
+ int32 windowid;
+ EmacsWindow *window;
+ window = (EmacsWindow *) Window ();
rq.just_exited_p = transit == B_EXITED_VIEW;
rq.x = point.x;
rq.y = point.y;
- rq.window = this->Window ();
+ rq.window = window;
rq.time = system_time ();
+ if (drag_msg && (drag_msg->IsSourceRemote ()
+ || drag_msg->FindInt32 ("emacs:window_id",
+ &windowid) != B_OK
+ || windowid != window->window_id))
+ rq.dnd_message = true;
+ else
+ rq.dnd_message = false;
+
if (ToolTip ())
ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x),
-(point.y - tt_absl_pos.y)));
@@ -1688,10 +1794,35 @@ public:
}
void
+ Pulse (void)
+ {
+ struct haiku_scroll_bar_part_event rq;
+ BPoint point;
+ uint32 buttons;
+
+ if (!dragging)
+ {
+ SetFlags (Flags () & ~B_PULSE_NEEDED);
+ return;
+ }
+
+ GetMouse (&point, &buttons, false);
+
+ if (ButtonRegionFor (current_part).Contains (point))
+ {
+ rq.scroll_bar = this;
+ rq.window = Window ();
+ rq.part = current_part;
+ haiku_write (SCROLL_BAR_PART_EVENT, &rq);
+ }
+
+ BScrollBar::Pulse ();
+ }
+
+ void
ValueChanged (float new_value)
{
struct haiku_scroll_bar_value_event rq;
- struct haiku_scroll_bar_part_event part;
new_value = Value ();
@@ -1702,11 +1833,7 @@ public:
if (dragging > 1)
{
SetValue (old_value);
-
- part.scroll_bar = this;
- part.window = Window ();
- part.part = current_part;
- haiku_write (SCROLL_BAR_PART_EVENT, &part);
+ SetFlags (Flags () | B_PULSE_NEEDED);
}
else
dragging++;
@@ -1846,6 +1973,12 @@ public:
dragging = 1;
current_part = HAIKU_SCROLL_BAR_DOWN_BUTTON;
+ if (Value () == max_value)
+ {
+ SetFlags (Flags () | B_PULSE_NEEDED);
+ dragging = 2;
+ }
+
haiku_write (SCROLL_BAR_PART_EVENT, &part);
goto out;
}
@@ -1889,7 +2022,7 @@ public:
rq.window = Window ();
haiku_write (SCROLL_BAR_DRAG_EVENT, &rq);
- dragging = false;
+ dragging = 0;
BScrollBar::MouseUp (pt);
}
@@ -3317,6 +3450,8 @@ void
be_get_version_string (char *version, int len)
{
std::strncpy (version, "Unknown Haiku release", len - 1);
+ version[len - 1] = '\0';
+
BPath path;
if (find_directory (B_BEOS_LIB_DIRECTORY, &path) == B_OK)
{
@@ -3330,7 +3465,10 @@ be_get_version_string (char *version, int len)
&& appFileInfo.GetVersionInfo (&versionInfo,
B_APP_VERSION_KIND) == B_OK
&& versionInfo.short_info[0] != '\0')
- std::strncpy (version, versionInfo.short_info, len - 1);
+ {
+ std::strncpy (version, versionInfo.short_info, len - 1);
+ version[len - 1] = '\0';
+ }
}
}
@@ -3953,20 +4091,29 @@ be_drag_message_thread_entry (void *thread_data)
return 0;
}
-void
-be_drag_message (void *view, void *message,
+bool
+be_drag_message (void *view, void *message, bool allow_same_view,
void (*block_input_function) (void),
void (*unblock_input_function) (void),
- void (*process_pending_signals_function) (void))
+ void (*process_pending_signals_function) (void),
+ bool (*should_quit_function) (void))
{
EmacsView *vw = (EmacsView *) view;
+ EmacsWindow *window = (EmacsWindow *) vw->Window ();
BMessage *msg = (BMessage *) message;
BMessage wait_for_release;
BMessenger messenger (vw);
+ BMessage cancel_message (CANCEL_DROP);
struct object_wait_info infos[2];
ssize_t stat;
block_input_function ();
+
+ if (!allow_same_view &&
+ (msg->ReplaceInt32 ("emacs:window_id", window->window_id)
+ == B_NAME_NOT_FOUND))
+ msg->AddInt32 ("emacs:window_id", window->window_id);
+
if (!vw->LockLooper ())
gui_abort ("Failed to lock view looper for drag");
@@ -3986,12 +4133,14 @@ be_drag_message (void *view, void *message,
unblock_input_function ();
if (infos[1].object < B_OK)
- return;
+ return false;
block_input_function ();
resume_thread (infos[1].object);
unblock_input_function ();
+ drag_and_drop_in_progress = true;
+
while (true)
{
block_input_function ();
@@ -4008,10 +4157,35 @@ be_drag_message (void *view, void *message,
if (infos[0].events & B_EVENT_READ)
process_pending_signals_function ();
+ if (should_quit_function ())
+ {
+ /* Do the best we can to prevent something from being
+ dropped, since Haiku doesn't provide a way to actually
+ cancel drag-and-drop. */
+ if (vw->LockLooper ())
+ {
+ vw->DragMessage (&cancel_message, BRect (0, 0, 0, 0));
+ vw->UnlockLooper ();
+ }
+
+ messenger.SendMessage (CANCEL_DROP);
+ drag_and_drop_in_progress = false;
+ return true;
+ }
+
if (infos[1].events & B_EVENT_INVALID)
- return;
+ {
+ drag_and_drop_in_progress = false;
+ return false;
+ }
infos[0].events = B_EVENT_READ;
infos[1].events = B_EVENT_INVALID;
}
}
+
+bool
+be_drag_and_drop_in_progress (void)
+{
+ return drag_and_drop_in_progress;
+}
diff --git a/src/haiku_support.h b/src/haiku_support.h
index af7216286a7..d0a78c693b9 100644
--- a/src/haiku_support.h
+++ b/src/haiku_support.h
@@ -159,6 +159,7 @@ struct haiku_mouse_motion_event
int x;
int y;
bigtime_t time;
+ bool dnd_message;
};
struct haiku_menu_bar_left_event
@@ -220,10 +221,8 @@ struct haiku_menu_bar_help_event
struct haiku_zoom_event
{
void *window;
- int x;
- int y;
- int width;
- int height;
+
+ bool zoomed;
};
#define FSPEC_FAMILY 1
@@ -945,11 +944,15 @@ extern "C"
extern void
BMessage_delete (void *message);
- extern void
- be_drag_message (void *view, void *message,
+ extern bool
+ be_drag_message (void *view, void *message, bool allow_same_view,
void (*block_input_function) (void),
void (*unblock_input_function) (void),
- void (*process_pending_signals_function) (void));
+ void (*process_pending_signals_function) (void),
+ bool (*should_quit_function) (void));
+
+ extern bool
+ be_drag_and_drop_in_progress (void);
#ifdef __cplusplus
extern void *
diff --git a/src/haikufns.c b/src/haikufns.c
index 7bb613af6e2..ef95d42f0f1 100644
--- a/src/haikufns.c
+++ b/src/haikufns.c
@@ -582,6 +582,11 @@ haiku_create_frame (Lisp_Object parms)
else
cascade_target = NULL;
+ /* Always cascade from the most toplevel frame. */
+
+ while (cascade_target && FRAME_PARENT_FRAME (cascade_target))
+ cascade_target = FRAME_PARENT_FRAME (cascade_target);
+
parms = Fcopy_alist (parms);
Vx_resource_name = Vinvocation_name;
@@ -624,6 +629,7 @@ haiku_create_frame (Lisp_Object parms)
f = make_frame_without_minibuffer (tem, kb, display);
else
f = make_frame (1);
+
XSETFRAME (frame, f);
f->terminal = dpyinfo->terminal;
@@ -631,11 +637,6 @@ haiku_create_frame (Lisp_Object parms)
f->output_method = output_haiku;
f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku);
- f->output_data.haiku->pending_zoom_x = INT_MIN;
- f->output_data.haiku->pending_zoom_y = INT_MIN;
- f->output_data.haiku->pending_zoom_width = INT_MIN;
- f->output_data.haiku->pending_zoom_height = INT_MIN;
-
fset_icon_name (f, gui_display_get_arg (dpyinfo, parms, Qicon_name,
"iconName", "Title",
RES_TYPE_STRING));
@@ -766,38 +767,27 @@ haiku_create_frame (Lisp_Object parms)
f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem));
block_input ();
-#define ASSIGN_CURSOR(cursor, be_cursor) \
- (FRAME_OUTPUT_DATA (f)->cursor = be_cursor)
-
- ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ());
- ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ());
- ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ());
- ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ());
- ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ());
- ASSIGN_CURSOR (horizontal_drag_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST));
- ASSIGN_CURSOR (vertical_drag_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH));
- ASSIGN_CURSOR (left_edge_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_WEST));
- ASSIGN_CURSOR (top_left_corner_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST));
- ASSIGN_CURSOR (top_edge_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_NORTH));
- ASSIGN_CURSOR (top_right_corner_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST));
- ASSIGN_CURSOR (right_edge_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_EAST));
- ASSIGN_CURSOR (bottom_right_corner_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST));
- ASSIGN_CURSOR (bottom_edge_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_SOUTH));
- ASSIGN_CURSOR (bottom_left_corner_cursor,
- BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST));
- ASSIGN_CURSOR (no_cursor,
- BCursor_from_id (CURSOR_ID_NO_CURSOR));
-
- ASSIGN_CURSOR (current_cursor, FRAME_OUTPUT_DATA (f)->text_cursor);
+#define ASSIGN_CURSOR(cursor) \
+ (FRAME_OUTPUT_DATA (f)->cursor = dpyinfo->cursor)
+
+ ASSIGN_CURSOR (text_cursor);
+ ASSIGN_CURSOR (nontext_cursor);
+ ASSIGN_CURSOR (modeline_cursor);
+ ASSIGN_CURSOR (hand_cursor);
+ ASSIGN_CURSOR (hourglass_cursor);
+ ASSIGN_CURSOR (horizontal_drag_cursor);
+ ASSIGN_CURSOR (vertical_drag_cursor);
+ ASSIGN_CURSOR (left_edge_cursor);
+ ASSIGN_CURSOR (top_left_corner_cursor);
+ ASSIGN_CURSOR (top_edge_cursor);
+ ASSIGN_CURSOR (top_right_corner_cursor);
+ ASSIGN_CURSOR (right_edge_cursor);
+ ASSIGN_CURSOR (bottom_right_corner_cursor);
+ ASSIGN_CURSOR (bottom_edge_cursor);
+ ASSIGN_CURSOR (bottom_left_corner_cursor);
+ ASSIGN_CURSOR (no_cursor);
+
+ FRAME_OUTPUT_DATA (f)->current_cursor = dpyinfo->text_cursor;
#undef ASSIGN_CURSOR
f->terminal->reference_count++;
@@ -826,6 +816,11 @@ haiku_create_frame (Lisp_Object parms)
|| !FRAME_LIVE_P (XFRAME (parent_frame)))
parent_frame = Qnil;
+ /* It doesn't make sense to center child frames, the resulting
+ position makes no sense. */
+ if (!NILP (parent_frame))
+ window_prompting |= PPosition;
+
fset_parent_frame (f, parent_frame);
store_frame_param (f, Qparent_frame, parent_frame);
@@ -961,11 +956,6 @@ haiku_create_tip_frame (Lisp_Object parms)
f->output_method = output_haiku;
f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku);
- f->output_data.haiku->pending_zoom_x = INT_MIN;
- f->output_data.haiku->pending_zoom_y = INT_MIN;
- f->output_data.haiku->pending_zoom_width = INT_MIN;
- f->output_data.haiku->pending_zoom_height = INT_MIN;
-
f->tooltip = true;
fset_icon_name (f, Qnil);
FRAME_DISPLAY_INFO (f) = dpyinfo;
@@ -1565,25 +1555,6 @@ haiku_free_frame_resources (struct frame *f)
if (window)
BWindow_quit (window);
- /* Free cursors */
-
- BCursor_delete (f->output_data.haiku->text_cursor);
- BCursor_delete (f->output_data.haiku->nontext_cursor);
- BCursor_delete (f->output_data.haiku->modeline_cursor);
- BCursor_delete (f->output_data.haiku->hand_cursor);
- BCursor_delete (f->output_data.haiku->hourglass_cursor);
- BCursor_delete (f->output_data.haiku->horizontal_drag_cursor);
- BCursor_delete (f->output_data.haiku->vertical_drag_cursor);
- BCursor_delete (f->output_data.haiku->left_edge_cursor);
- BCursor_delete (f->output_data.haiku->top_left_corner_cursor);
- BCursor_delete (f->output_data.haiku->top_edge_cursor);
- BCursor_delete (f->output_data.haiku->top_right_corner_cursor);
- BCursor_delete (f->output_data.haiku->right_edge_cursor);
- BCursor_delete (f->output_data.haiku->bottom_right_corner_cursor);
- BCursor_delete (f->output_data.haiku->bottom_edge_cursor);
- BCursor_delete (f->output_data.haiku->bottom_left_corner_cursor);
- BCursor_delete (f->output_data.haiku->no_cursor);
-
xfree (FRAME_OUTPUT_DATA (f));
FRAME_OUTPUT_DATA (f) = NULL;
diff --git a/src/haikufont.c b/src/haikufont.c
index 5099285f100..b9f6dc2fe8e 100644
--- a/src/haikufont.c
+++ b/src/haikufont.c
@@ -437,6 +437,7 @@ haikufont_spec_or_entity_to_pattern (Lisp_Object ent,
strncpy ((char *) &ptn->style,
SSDATA (SYMBOL_NAME (tem)),
sizeof ptn->style - 1);
+ ptn->style[sizeof ptn->style - 1] = '\0';
}
tem = FONT_SLANT_SYMBOLIC (ent);
@@ -475,6 +476,7 @@ haikufont_spec_or_entity_to_pattern (Lisp_Object ent,
strncpy ((char *) &ptn->family,
SSDATA (SYMBOL_NAME (tem)),
sizeof ptn->family - 1);
+ ptn->family[sizeof ptn->family - 1] = '\0';
}
tem = assq_no_quit (QCscript, AREF (ent, FONT_EXTRA_INDEX));
diff --git a/src/haikuimage.c b/src/haikuimage.c
index fe960bbc291..af3021c5cd9 100644
--- a/src/haikuimage.c
+++ b/src/haikuimage.c
@@ -42,8 +42,10 @@ haiku_can_use_native_image_api (Lisp_Object type)
mime_type = "image/jpeg";
else if (EQ (type, Qpng))
mime_type = "image/png";
+#ifndef HAVE_GIF
else if (EQ (type, Qgif))
mime_type = "image/gif";
+#endif
else if (EQ (type, Qtiff))
mime_type = "image/tiff";
else if (EQ (type, Qbmp))
@@ -52,8 +54,12 @@ haiku_can_use_native_image_api (Lisp_Object type)
mime_type = "image/svg";
else if (EQ (type, Qpbm))
mime_type = "image/pbm";
+ /* Don't use native image APIs for image types that have animations,
+ since those aren't supported by the Translation Kit. */
+#ifndef HAVE_WEBP
else if (EQ (type, Qwebp))
mime_type = "image/webp";
+#endif
if (!mime_type)
return 0;
@@ -107,5 +113,4 @@ haiku_load_image (struct frame *f, struct image *img,
void
syms_of_haikuimage (void)
{
- DEFSYM (Qbmp, "bmp");
}
diff --git a/src/haikumenu.c b/src/haikumenu.c
index 8da00ffcb05..4cee69826da 100644
--- a/src/haikumenu.c
+++ b/src/haikumenu.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "haiku_support.h"
static Lisp_Object *volatile menu_item_selection;
+static struct timespec menu_timer_timespec;
int popup_activated_p = 0;
@@ -340,12 +341,35 @@ haiku_menu_show_help (void *help, void *data)
show_help_echo (Qnil, Qnil, Qnil, Qnil);
}
+static Lisp_Object
+haiku_process_pending_signals_for_menu_1 (void *ptr)
+{
+ menu_timer_timespec = timer_check ();
+
+ return Qnil;
+}
+
+static Lisp_Object
+haiku_process_pending_signals_for_menu_2 (enum nonlocal_exit exit, Lisp_Object error)
+{
+ menu_timer_timespec.tv_sec = 0;
+ menu_timer_timespec.tv_nsec = -1;
+
+ return Qnil;
+}
+
static struct timespec
haiku_process_pending_signals_for_menu (void)
{
process_pending_signals ();
- return timer_check ();
+ /* The original idea was to let timers throw so that timeouts can
+ work correctly, but there's no way to pop down a BPopupMenu
+ that's currently popped up. */
+ internal_catch_all (haiku_process_pending_signals_for_menu_1, NULL,
+ haiku_process_pending_signals_for_menu_2);
+
+ return menu_timer_timespec;
}
Lisp_Object
diff --git a/src/haikuselect.c b/src/haikuselect.c
index 7474ff12327..a186acc66ff 100644
--- a/src/haikuselect.c
+++ b/src/haikuselect.c
@@ -27,110 +27,150 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <stdlib.h>
-static Lisp_Object
-haiku_selection_data_1 (Lisp_Object clipboard)
-{
- Lisp_Object result = Qnil;
- char *targets[256];
+/* The frame that is currently the source of a drag-and-drop
+ operation, or NULL if none is in progress. The reason for this
+ variable is to prevent it from being deleted, which really breaks
+ the nested event loop inside be_drag_message. */
+struct frame *haiku_dnd_frame;
- block_input ();
- if (EQ (clipboard, QPRIMARY))
- BClipboard_primary_targets ((char **) &targets, 256);
- else if (EQ (clipboard, QSECONDARY))
- BClipboard_secondary_targets ((char **) &targets, 256);
- else if (EQ (clipboard, QCLIPBOARD))
- BClipboard_system_targets ((char **) &targets, 256);
- else
- {
- unblock_input ();
- signal_error ("Bad clipboard", clipboard);
- }
-
- for (int i = 0; targets[i]; ++i)
- {
- result = Fcons (build_unibyte_string (targets[i]),
- result);
- free (targets[i]);
- }
- unblock_input ();
-
- return result;
-}
-
-DEFUN ("haiku-selection-targets", Fhaiku_selection_targets,
- Shaiku_selection_targets, 1, 1, 0,
- doc: /* Find the types of data available from CLIPBOARD.
-CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'.
-Return the available types as a list of strings. */)
- (Lisp_Object clipboard)
-{
- return haiku_selection_data_1 (clipboard);
-}
+static void haiku_lisp_to_message (Lisp_Object, void *);
DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data,
2, 2, 0,
doc: /* Retrieve content typed as NAME from the clipboard
CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or
-`CLIPBOARD'. NAME is a MIME type denoting the type of the data to
-fetch. */)
+`CLIPBOARD'. NAME is a string describing the MIME type denoting the
+type of the data to fetch. If NAME is nil, then the entire contents
+of the clipboard will be returned instead, as a serialized system
+message in the format accepted by `haiku-drag-message', which see. */)
(Lisp_Object clipboard, Lisp_Object name)
{
- CHECK_SYMBOL (clipboard);
- CHECK_STRING (name);
char *dat;
ssize_t len;
+ Lisp_Object str;
+ void *message;
+ enum haiku_clipboard clipboard_name;
+ int rc;
- block_input ();
- if (EQ (clipboard, QPRIMARY))
- dat = BClipboard_find_primary_selection_data (SSDATA (name), &len);
- else if (EQ (clipboard, QSECONDARY))
- dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len);
- else if (EQ (clipboard, QCLIPBOARD))
- dat = BClipboard_find_system_data (SSDATA (name), &len);
- else
+ CHECK_SYMBOL (clipboard);
+
+ if (!EQ (clipboard, QPRIMARY) && !EQ (clipboard, QSECONDARY)
+ && !EQ (clipboard, QCLIPBOARD))
+ signal_error ("Invalid clipboard", clipboard);
+
+ if (!NILP (name))
{
+ CHECK_STRING (name);
+
+ block_input ();
+ if (EQ (clipboard, QPRIMARY))
+ dat = BClipboard_find_primary_selection_data (SSDATA (name), &len);
+ else if (EQ (clipboard, QSECONDARY))
+ dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len);
+ else
+ dat = BClipboard_find_system_data (SSDATA (name), &len);
unblock_input ();
- signal_error ("Bad clipboard", clipboard);
- }
- unblock_input ();
- if (!dat)
- return Qnil;
+ if (!dat)
+ return Qnil;
- Lisp_Object str = make_unibyte_string (dat, len);
+ str = make_unibyte_string (dat, len);
- /* `foreign-selection' just means that the selection has to be
- decoded by `gui-get-selection'. It has no other meaning,
- AFAICT. */
- Fput_text_property (make_fixnum (0), make_fixnum (len),
- Qforeign_selection, Qt, str);
+ /* `foreign-selection' just means that the selection has to be
+ decoded by `gui-get-selection'. It has no other meaning,
+ AFAICT. */
+ Fput_text_property (make_fixnum (0), make_fixnum (len),
+ Qforeign_selection, Qt, str);
- block_input ();
- BClipboard_free_data (dat);
- unblock_input ();
+ block_input ();
+ BClipboard_free_data (dat);
+ unblock_input ();
+ }
+ else
+ {
+ if (EQ (clipboard, QPRIMARY))
+ clipboard_name = CLIPBOARD_PRIMARY;
+ else if (EQ (clipboard, QSECONDARY))
+ clipboard_name = CLIPBOARD_SECONDARY;
+ else
+ clipboard_name = CLIPBOARD_CLIPBOARD;
+
+ block_input ();
+ rc = be_lock_clipboard_message (clipboard_name, &message, false);
+ unblock_input ();
+
+ if (rc)
+ signal_error ("Couldn't open clipboard", clipboard);
+
+ block_input ();
+ str = haiku_message_to_lisp (message);
+ be_unlock_clipboard (clipboard_name, true);
+ unblock_input ();
+ }
return str;
}
+static void
+haiku_unwind_clipboard_lock (int clipboard)
+{
+ be_unlock_clipboard (clipboard, false);
+}
+
DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put,
- 3, 4, 0,
+ 2, 4, 0,
doc: /* Add or remove content from the clipboard CLIPBOARD.
CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME
is a MIME type denoting the type of the data to add. DATA is the
string that will be placed in the clipboard, or nil if the content is
to be removed. CLEAR, if non-nil, means to erase all the previous
-contents of the clipboard. */)
+contents of the clipboard.
+
+Alternatively, NAME can be a system message in the format accepted by
+`haiku-drag-message', which will replace the contents of CLIPBOARD.
+In that case, the arguments after NAME are ignored. */)
(Lisp_Object clipboard, Lisp_Object name, Lisp_Object data,
Lisp_Object clear)
{
+ enum haiku_clipboard clipboard_name;
+ specpdl_ref ref;
+ char *dat;
+ ptrdiff_t len;
+ int rc;
+ void *message;
+
+ if (CONSP (name) || NILP (name))
+ {
+ if (EQ (clipboard, QPRIMARY))
+ clipboard_name = CLIPBOARD_PRIMARY;
+ else if (EQ (clipboard, QSECONDARY))
+ clipboard_name = CLIPBOARD_SECONDARY;
+ else if (EQ (clipboard, QCLIPBOARD))
+ clipboard_name = CLIPBOARD_CLIPBOARD;
+ else
+ signal_error ("Invalid clipboard", clipboard);
+
+ rc = be_lock_clipboard_message (clipboard_name,
+ &message, true);
+
+ if (rc)
+ signal_error ("Couldn't open clipboard", clipboard);
+
+ ref = SPECPDL_INDEX ();
+ record_unwind_protect_int (haiku_unwind_clipboard_lock,
+ clipboard_name);
+ haiku_lisp_to_message (name, message);
+
+ return unbind_to (ref, Qnil);
+ }
+
CHECK_SYMBOL (clipboard);
CHECK_STRING (name);
if (!NILP (data))
CHECK_STRING (data);
- block_input ();
- char *dat = !NILP (data) ? SSDATA (data) : NULL;
- ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0;
+ dat = !NILP (data) ? SSDATA (data) : NULL;
+ len = !NILP (data) ? SBYTES (data) : 0;
if (EQ (clipboard, QPRIMARY))
BClipboard_set_primary_selection_data (SSDATA (name), dat, len,
@@ -145,7 +185,6 @@ contents of the clipboard. */)
unblock_input ();
signal_error ("Bad clipboard", clipboard);
}
- unblock_input ();
return Qnil;
}
@@ -180,21 +219,8 @@ same as `SECONDARY'. */)
return value ? Qt : Qnil;
}
-/* Return the Lisp representation of MESSAGE.
-
- It is an alist of strings, denoting message field names, to a list
- of the form (TYPE DATA ...), where TYPE is an integer denoting the
- system data type of DATA, and DATA is in the general case a unibyte
- string.
-
- If TYPE is a symbol instead of an integer, then DATA was specially
- decoded. If TYPE is `ref', then DATA is the absolute file name of
- a file, or nil if decoding the file name failed. If TYPE is
- `string', then DATA is a unibyte string. If TYPE is `short', then
- DATA is a 16-bit signed integer. If TYPE is `long', then DATA is a
- 32-bit signed integer. If TYPE is `llong', then DATA is a 64-bit
- signed integer. If TYPE is `byte' or `char', then DATA is an 8-bit
- signed integer. If TYPE is `bool', then DATA is a boolean. */
+/* Return the Lisp representation of MESSAGE. See Fhaiku_drag_message
+ for the format of the object returned. */
Lisp_Object
haiku_message_to_lisp (void *message)
{
@@ -205,6 +231,8 @@ haiku_message_to_lisp (void *message)
ssize_t buf_size;
int32 i, j, count, type_code;
int rc;
+ void *msg;
+ float point_x, point_y;
for (i = 0; !be_enum_message (message, &type_code, i,
&count, &name); ++i)
@@ -221,6 +249,15 @@ haiku_message_to_lisp (void *message)
switch (type_code)
{
+ case 'MSGG':
+ msg = be_get_message_message (message, name, j);
+ if (!msg)
+ memory_full (SIZE_MAX);
+ t1 = haiku_message_to_lisp (msg);
+ BMessage_delete (msg);
+
+ break;
+
case 'BOOL':
t1 = (*(bool *) buf) ? Qt : Qnil;
break;
@@ -239,9 +276,25 @@ haiku_message_to_lisp (void *message)
memory_full (SIZE_MAX);
t1 = build_string (pbuf);
+
free (pbuf);
break;
+ case 'BPNT':
+ rc = be_get_point_data (message, name,
+ j, &point_x,
+ &point_y);
+
+ if (rc)
+ {
+ t1 = Qnil;
+ break;
+ }
+
+ t1 = Fcons (make_float (point_x),
+ make_float (point_y));
+ break;
+
case 'SHRT':
t1 = make_fixnum (*(int16 *) buf);
break;
@@ -259,6 +312,14 @@ haiku_message_to_lisp (void *message)
t1 = make_fixnum (*(int8 *) buf);
break;
+ case 'SIZT':
+ t1 = make_uint ((uintmax_t) *(size_t *) buf);
+ break;
+
+ case 'SSZT':
+ t1 = make_int ((intmax_t) *(ssize_t *) buf);
+ break;
+
default:
t1 = make_uninit_string (buf_size);
memcpy (SDATA (t1), buf, buf_size);
@@ -301,6 +362,22 @@ haiku_message_to_lisp (void *message)
t2 = Qbool;
break;
+ case 'MSGG':
+ t2 = Qmessage;
+ break;
+
+ case 'SIZT':
+ t2 = Qsize_t;
+ break;
+
+ case 'SSZT':
+ t2 = Qssize_t;
+ break;
+
+ case 'BPNT':
+ t2 = Qpoint;
+ break;
+
default:
t2 = make_int (type_code);
}
@@ -309,7 +386,8 @@ haiku_message_to_lisp (void *message)
list = Fcons (Fcons (build_string_from_utf8 (name), tem), list);
}
- return list;
+ tem = Fcons (Qtype, make_uint (be_get_message_type (message)));
+ return Fcons (tem, list);
}
static int32
@@ -337,6 +415,14 @@ lisp_to_type_code (Lisp_Object obj)
return 'CHAR';
else if (EQ (obj, Qbool))
return 'BOOL';
+ else if (EQ (obj, Qmessage))
+ return 'MSGG';
+ else if (EQ (obj, Qsize_t))
+ return 'SIZT';
+ else if (EQ (obj, Qssize_t))
+ return 'SSZT';
+ else if (EQ (obj, Qpoint))
+ return 'BPNT';
else
return -1;
}
@@ -350,15 +436,52 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
int64 llong_data;
int8 char_data;
bool bool_data;
+ void *msg_data;
+ size_t sizet_data;
+ ssize_t ssizet_data;
intmax_t t4;
+ uintmax_t t5;
+ float t6, t7;
+ int rc;
+ specpdl_ref ref;
CHECK_LIST (obj);
for (tem = obj; CONSP (tem); tem = XCDR (tem))
{
+ maybe_quit ();
t1 = XCAR (tem);
CHECK_CONS (t1);
name = XCAR (t1);
+
+ if (EQ (name, Qtype))
+ {
+ t2 = XCDR (t1);
+
+ if (BIGNUMP (t2))
+ {
+ t5 = bignum_to_uintmax (t2);
+
+ if (!t5 || t5 > TYPE_MAXIMUM (uint32))
+ signal_error ("Value too large", t2);
+
+ block_input ();
+ be_set_message_type (message, t5);
+ unblock_input ();
+ }
+ else
+ {
+ if (!TYPE_RANGED_FIXNUMP (uint32, t2))
+ signal_error ("Invalid data type", t2);
+
+ block_input ();
+ be_set_message_type (message, XFIXNAT (t2));
+ unblock_input ();
+ }
+
+ continue;
+ }
+
CHECK_STRING (name);
t1 = XCDR (t1);
@@ -373,12 +496,52 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
CHECK_LIST (t1);
for (t2 = XCDR (t1); CONSP (t2); t2 = XCDR (t2))
{
+ maybe_quit ();
data = XCAR (t2);
+ if (FIXNUMP (type_sym) || BIGNUMP (type_sym))
+ goto decode_normally;
+
switch (type_code)
{
+ case 'MSGG':
+ ref = SPECPDL_INDEX ();
+
+ block_input ();
+ msg_data = be_create_simple_message ();
+ unblock_input ();
+
+ record_unwind_protect_ptr (BMessage_delete, msg_data);
+ haiku_lisp_to_message (data, msg_data);
+
+ block_input ();
+ rc = be_add_message_message (message, SSDATA (name), msg_data);
+ unblock_input ();
+
+ if (rc)
+ signal_error ("Invalid message", msg_data);
+ unbind_to (ref, Qnil);
+ break;
+
case 'RREF':
- signal_error ("Cannot deserialize data type", type_sym);
+ CHECK_STRING (data);
+
+ if (be_add_refs_data (message, SSDATA (name), SSDATA (data))
+ && haiku_signal_invalid_refs)
+ signal_error ("Invalid file name", data);
+ break;
+
+ case 'BPNT':
+ CHECK_CONS (data);
+ CHECK_NUMBER (XCAR (data));
+ CHECK_NUMBER (XCDR (data));
+
+ t6 = XFLOATINT (XCAR (data));
+ t7 = XFLOATINT (XCDR (data));
+
+ if (be_add_point_data (message, SSDATA (name),
+ t6, t7))
+ signal_error ("Invalid point", data);
break;
case 'SHRT':
@@ -387,10 +550,13 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
short_data = XFIXNUM (data);
block_input ();
- be_add_message_data (message, SSDATA (name),
- type_code, &short_data,
- sizeof short_data);
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &short_data,
+ sizeof short_data);
unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add short", data);
break;
case 'LONG':
@@ -414,10 +580,13 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
}
block_input ();
- be_add_message_data (message, SSDATA (name),
- type_code, &long_data,
- sizeof long_data);
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &long_data,
+ sizeof long_data);
unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add long", data);
break;
case 'LLNG':
@@ -440,10 +609,70 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
}
block_input ();
- be_add_message_data (message, SSDATA (name),
- type_code, &llong_data,
- sizeof llong_data);
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &llong_data,
+ sizeof llong_data);
unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add llong", data);
+ break;
+
+ case 'SIZT':
+ if (BIGNUMP (data))
+ {
+ t4 = bignum_to_intmax (data);
+
+ if (!t4 || t4 > TYPE_MAXIMUM (size_t))
+ signal_error ("Value too large", data);
+
+ sizet_data = (size_t) t4;
+ }
+ else
+ {
+ if (!TYPE_RANGED_FIXNUMP (size_t, data))
+ signal_error ("Invalid value", data);
+
+ sizet_data = (int64) XFIXNUM (data);
+ }
+
+ block_input ();
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &sizet_data,
+ sizeof sizet_data);
+ unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add sizet", data);
+ break;
+
+ case 'SSZT':
+ if (BIGNUMP (data))
+ {
+ t4 = bignum_to_intmax (data);
+
+ if (!t4 || t4 > TYPE_MINIMUM (ssize_t)
+ || t4 < TYPE_MAXIMUM (ssize_t))
+ signal_error ("Value too large", data);
+
+ ssizet_data = (ssize_t) t4;
+ }
+ else
+ {
+ if (!TYPE_RANGED_FIXNUMP (ssize_t, data))
+ signal_error ("Invalid value", data);
+
+ ssizet_data = (int64) XFIXNUM (data);
+ }
+
+ block_input ();
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &ssizet_data,
+ sizeof ssizet_data);
+ unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add ssizet", data);
break;
case 'CHAR':
@@ -453,30 +682,40 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
char_data = XFIXNUM (data);
block_input ();
- be_add_message_data (message, SSDATA (name),
- type_code, &char_data,
- sizeof char_data);
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &char_data,
+ sizeof char_data);
unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add char", data);
break;
case 'BOOL':
bool_data = !NILP (data);
block_input ();
- be_add_message_data (message, SSDATA (name),
- type_code, &bool_data,
- sizeof bool_data);
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, &bool_data,
+ sizeof bool_data);
unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add bool", data);
break;
default:
+ decode_normally:
CHECK_STRING (data);
block_input ();
- be_add_message_data (message, SSDATA (name),
- type_code, SDATA (data),
- SBYTES (data));
+ rc = be_add_message_data (message, SSDATA (name),
+ type_code, SDATA (data),
+ SBYTES (data));
unblock_input ();
+
+ if (rc)
+ signal_error ("Failed to add", data);
}
}
CHECK_LIST_END (t2, t1);
@@ -484,8 +723,21 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
CHECK_LIST_END (tem, obj);
}
+static bool
+haiku_should_quit_drag (void)
+{
+ return !NILP (Vquit_flag);
+}
+
+static void
+haiku_unwind_drag_message (void *message)
+{
+ haiku_dnd_frame = NULL;
+ BMessage_delete (message);
+}
+
DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message,
- 2, 2, 0,
+ 2, 3, 0,
doc: /* Begin dragging MESSAGE from FRAME.
MESSAGE an alist of strings, denoting message field names, to a list
@@ -499,15 +751,29 @@ then DATA is a unibyte string. If TYPE is `short', then DATA is a
16-bit signed integer. If TYPE is `long', then DATA is a 32-bit
signed integer. If TYPE is `llong', then DATA is a 64-bit signed
integer. If TYPE is `byte' or `char', then DATA is an 8-bit signed
-integer. If TYPE is `bool', then DATA is a boolean.
+integer. If TYPE is `bool', then DATA is a boolean. If TYPE is
+`size_t', then DATA is an integer that can hold between 0 and the
+maximum value returned by the `sizeof' C operator on the current
+system. If TYPE is `ssize_t', then DATA is an integer that can hold
+values from -1 to the maximum value of the C data type `ssize_t' on
+the current system. If TYPE is `point', then DATA is a cons of float
+values describing the X and Y coordinates of an on-screen location.
+
+If the field name is not a string but the symbol `type', then it
+associates to a 32-bit unsigned integer describing the type of the
+system message.
FRAME is a window system frame that must be visible, from which the
-drag will originate. */)
- (Lisp_Object frame, Lisp_Object message)
+drag will originate.
+
+ALLOW-SAME-FRAME, if nil or not specified, means that MESSAGE will be
+ignored if it is dropped on top of FRAME. */)
+ (Lisp_Object frame, Lisp_Object message, Lisp_Object allow_same_frame)
{
specpdl_ref idx;
void *be_message;
struct frame *f;
+ bool rc;
idx = SPECPDL_INDEX ();
f = decode_window_system_frame (frame);
@@ -515,27 +781,68 @@ drag will originate. */)
if (!FRAME_VISIBLE_P (f))
error ("Frame is invisible");
+ haiku_dnd_frame = f;
be_message = be_create_simple_message ();
- record_unwind_protect_ptr (BMessage_delete, be_message);
+ record_unwind_protect_ptr (haiku_unwind_drag_message, be_message);
haiku_lisp_to_message (message, be_message);
- be_drag_message (FRAME_HAIKU_VIEW (f), be_message,
- block_input, unblock_input,
- process_pending_signals);
+ rc = be_drag_message (FRAME_HAIKU_VIEW (f), be_message,
+ !NILP (allow_same_frame),
+ block_input, unblock_input,
+ process_pending_signals,
+ haiku_should_quit_drag);
FRAME_DISPLAY_INFO (f)->grabbed = 0;
+ if (rc)
+ quit ();
+
return unbind_to (idx, Qnil);
}
+static Lisp_Object
+haiku_note_drag_motion_1 (void *data)
+{
+ if (!NILP (Vhaiku_drag_track_function))
+ return call0 (Vhaiku_drag_track_function);
+
+ return Qnil;
+}
+
+static Lisp_Object
+haiku_note_drag_motion_2 (enum nonlocal_exit exit, Lisp_Object error)
+{
+ return Qnil;
+}
+
+void
+haiku_note_drag_motion (void)
+{
+ internal_catch_all (haiku_note_drag_motion_1, NULL,
+ haiku_note_drag_motion_2);
+}
+
void
syms_of_haikuselect (void)
{
+ DEFVAR_BOOL ("haiku-signal-invalid-refs", haiku_signal_invalid_refs,
+ doc: /* If nil, silently ignore invalid file names in system messages.
+Otherwise, an error will be signalled if adding a file reference to a
+system message failed. */);
+ haiku_signal_invalid_refs = true;
+
+ DEFVAR_LISP ("haiku-drag-track-function", Vhaiku_drag_track_function,
+ doc: /* If non-nil, a function to call upon mouse movement while dragging a message.
+The function is called without any arguments. `mouse-position' can be
+used to retrieve the current position of the mouse. */);
+ Vhaiku_drag_track_function = Qnil;
+
DEFSYM (QSECONDARY, "SECONDARY");
DEFSYM (QCLIPBOARD, "CLIPBOARD");
DEFSYM (QSTRING, "STRING");
DEFSYM (QUTF8_STRING, "UTF8_STRING");
DEFSYM (Qforeign_selection, "foreign-selection");
DEFSYM (QTARGETS, "TARGETS");
+ DEFSYM (Qmessage, "message");
DEFSYM (Qstring, "string");
DEFSYM (Qref, "ref");
DEFSYM (Qshort, "short");
@@ -544,10 +851,15 @@ syms_of_haikuselect (void)
DEFSYM (Qbyte, "byte");
DEFSYM (Qchar, "char");
DEFSYM (Qbool, "bool");
+ DEFSYM (Qtype, "type");
+ DEFSYM (Qsize_t, "size_t");
+ DEFSYM (Qssize_t, "ssize_t");
+ DEFSYM (Qpoint, "point");
defsubr (&Shaiku_selection_data);
defsubr (&Shaiku_selection_put);
- defsubr (&Shaiku_selection_targets);
defsubr (&Shaiku_selection_owner_p);
defsubr (&Shaiku_drag_message);
+
+ haiku_dnd_frame = NULL;
}
diff --git a/src/haikuselect.h b/src/haikuselect.h
index 366890d1a46..bac9663c702 100644
--- a/src/haikuselect.h
+++ b/src/haikuselect.h
@@ -25,6 +25,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <SupportDefs.h>
+enum haiku_clipboard
+ {
+ CLIPBOARD_PRIMARY,
+ CLIPBOARD_SECONDARY,
+ CLIPBOARD_CLIPBOARD
+ };
+
#ifdef __cplusplus
#include <stdio.h>
extern "C"
@@ -87,10 +94,27 @@ extern "C"
ssize_t *size_return);
extern int be_get_refs_data (void *message, const char *name,
int32 index, char **path_buffer);
+ extern int be_get_point_data (void *message, const char *name,
+ int32 index, float *x, float *y);
+ extern uint32 be_get_message_type (void *message);
+ extern void be_set_message_type (void *message, uint32 what);
+ extern void *be_get_message_message (void *message, const char *name,
+ int32 index);
extern void *be_create_simple_message (void);
extern int be_add_message_data (void *message, const char *name,
int32 type_code, const void *buf,
ssize_t buf_size);
+ extern int be_add_refs_data (void *message, const char *name,
+ const char *filename);
+ extern int be_add_point_data (void *message, const char *name,
+ float x, float y);
+ extern int be_add_message_message (void *message, const char *name,
+ void *data);
+ extern int be_lock_clipboard_message (enum haiku_clipboard clipboard,
+ void **message_return,
+ bool clear);
+ extern void be_unlock_clipboard (enum haiku_clipboard clipboard,
+ bool discard);
#ifdef __cplusplus
};
#endif
diff --git a/src/haikuterm.c b/src/haikuterm.c
index 4ae64129ef1..f07e9e0b296 100644
--- a/src/haikuterm.c
+++ b/src/haikuterm.c
@@ -58,7 +58,7 @@ struct unhandled_event
uint8_t buffer[200];
};
-static bool any_help_event_p = false;
+static bool any_help_event_p;
char *
get_keysym_name (int keysym)
@@ -115,7 +115,44 @@ haiku_toolkit_position (struct frame *f, int x, int y,
static void
haiku_delete_terminal (struct terminal *terminal)
{
- emacs_abort ();
+ struct haiku_display_info *dpyinfo = terminal->display_info.haiku;
+ struct terminal *t;
+
+ if (!terminal->name)
+ return;
+
+ block_input ();
+
+ be_app_quit ();
+ delete_port (port_application_to_emacs);
+
+ BCursor_delete (dpyinfo->text_cursor);
+ BCursor_delete (dpyinfo->nontext_cursor);
+ BCursor_delete (dpyinfo->modeline_cursor);
+ BCursor_delete (dpyinfo->hand_cursor);
+ BCursor_delete (dpyinfo->hourglass_cursor);
+ BCursor_delete (dpyinfo->horizontal_drag_cursor);
+ BCursor_delete (dpyinfo->vertical_drag_cursor);
+ BCursor_delete (dpyinfo->left_edge_cursor);
+ BCursor_delete (dpyinfo->top_left_corner_cursor);
+ BCursor_delete (dpyinfo->top_edge_cursor);
+ BCursor_delete (dpyinfo->top_right_corner_cursor);
+ BCursor_delete (dpyinfo->right_edge_cursor);
+ BCursor_delete (dpyinfo->bottom_right_corner_cursor);
+ BCursor_delete (dpyinfo->bottom_edge_cursor);
+ BCursor_delete (dpyinfo->bottom_left_corner_cursor);
+ BCursor_delete (dpyinfo->no_cursor);
+
+ /* Close all frames and delete the generic struct terminal. */
+ for (t = terminal_list; t; t = t->next_terminal)
+ {
+ if (t->type == output_haiku && t->display_info.haiku == dpyinfo)
+ {
+ delete_terminal (t);
+ break;
+ }
+ }
+ unblock_input ();
}
static const char *
@@ -415,7 +452,8 @@ haiku_mouse_or_wdesc_frame (void *window)
? x_display_list->last_mouse_frame
: NULL);
- if (lm_f && !EQ (track_mouse, Qdropping))
+ if (lm_f && !EQ (track_mouse, Qdropping)
+ && !EQ (track_mouse, Qdrag_source))
return lm_f;
else
{
@@ -1817,6 +1855,22 @@ static void
haiku_set_window_size (struct frame *f, bool change_gravity,
int width, int height)
{
+ Lisp_Object frame;
+
+ /* On X Windows, window managers typically disallow resizing a
+ window when it is fullscreen. Do the same here. */
+
+ XSETFRAME (frame, f);
+ if (!NILP (Fframe_parameter (frame, Qfullscreen))
+ /* Only do this if the fullscreen status has actually been
+ applied. */
+ && f->want_fullscreen == FULLSCREEN_NONE
+ /* And if the configury during frame completion has been
+ completed. Otherwise, there will be no valid "old size" to
+ go back to. */
+ && FRAME_OUTPUT_DATA (f)->configury_done)
+ return;
+
haiku_update_size_hints (f);
if (FRAME_HAIKU_WINDOW (f))
@@ -2513,17 +2567,26 @@ haiku_scroll_run (struct window *w, struct run *run)
unblock_input ();
}
+/* Haiku doesn't provide any way to get the frame actually underneath
+ the pointer, so we typically return dpyinfo->last_mouse_frame if
+ the display is grabbed and `track-mouse' is not `dropping' or
+ `drag-source'; failing that, we return the selected frame, and
+ finally a random window system frame (as long as `track-mouse' is
+ not `drag-source') if that didn't work either. */
static void
haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y,
Time *timestamp)
{
Lisp_Object frame, tail;
- struct frame *f1 = NULL;
+ struct frame *f1;
+ int screen_x, screen_y;
+ void *view;
if (!fp)
return;
+ f1 = NULL;
block_input ();
FOR_EACH_FRAME (tail, frame)
@@ -2532,15 +2595,14 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
XFRAME (frame)->mouse_moved = false;
}
- if (gui_mouse_grabbed (x_display_list) && !EQ (track_mouse, Qdropping))
+ if (gui_mouse_grabbed (x_display_list)
+ && !EQ (track_mouse, Qdropping)
+ && !EQ (track_mouse, Qdrag_source))
f1 = x_display_list->last_mouse_frame;
+ else
+ f1 = x_display_list->last_mouse_motion_frame;
- if (!f1 || FRAME_TOOLTIP_P (f1))
- f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (x_display_list))
- ? x_display_list->last_mouse_frame
- : NULL);
-
- if (!f1 && insist > 0)
+ if (!f1 && FRAME_HAIKU_P (SELECTED_FRAME ()))
f1 = SELECTED_FRAME ();
if (!f1 || (!FRAME_HAIKU_P (f1) && (insist > 0)))
@@ -2549,26 +2611,37 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
!FRAME_TOOLTIP_P (XFRAME (frame)))
f1 = XFRAME (frame);
- if (FRAME_TOOLTIP_P (f1))
+ if (f1 && FRAME_TOOLTIP_P (f1))
f1 = NULL;
if (f1 && FRAME_HAIKU_P (f1))
{
- int sx, sy;
- void *view = FRAME_HAIKU_VIEW (f1);
+ view = FRAME_HAIKU_VIEW (f1);
+
if (view)
{
- BView_get_mouse (view, &sx, &sy);
-
- remember_mouse_glyph (f1, sx, sy, &x_display_list->last_mouse_glyph);
+ BView_get_mouse (view, &screen_x, &screen_y);
+ remember_mouse_glyph (f1, screen_x, screen_y,
+ &x_display_list->last_mouse_glyph);
x_display_list->last_mouse_glyph_frame = f1;
*bar_window = Qnil;
*part = scroll_bar_above_handle;
- *fp = f1;
+
+ /* If track-mouse is `drag-source' and the mouse pointer is
+ certain to not be actually under the chosen frame, return
+ NULL in FP to at least try being consistent with X. */
+ if (EQ (track_mouse, Qdrag_source)
+ && (screen_x < 0 || screen_y < 0
+ || screen_x >= FRAME_PIXEL_WIDTH (f1)
+ || screen_y >= FRAME_PIXEL_HEIGHT (f1)))
+ *fp = NULL;
+ else
+ *fp = f1;
+
*timestamp = x_display_list->last_mouse_movement_time;
- XSETINT (*x, sx);
- XSETINT (*y, sy);
+ XSETINT (*x, screen_x);
+ XSETINT (*y, screen_y);
}
}
@@ -2817,19 +2890,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
cancel_mouse_face (f);
haiku_clear_under_internal_border (f);
}
-
- if (FRAME_OUTPUT_DATA (f)->pending_zoom_width != width ||
- FRAME_OUTPUT_DATA (f)->pending_zoom_height != height)
- {
- FRAME_OUTPUT_DATA (f)->zoomed_p = 0;
- haiku_make_fullscreen_consistent (f);
- }
- else
- {
- FRAME_OUTPUT_DATA (f)->zoomed_p = 1;
- FRAME_OUTPUT_DATA (f)->pending_zoom_width = INT_MIN;
- FRAME_OUTPUT_DATA (f)->pending_zoom_height = INT_MIN;
- }
break;
}
case FRAME_EXPOSED:
@@ -2930,6 +2990,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
struct haiku_mouse_motion_event *b = buf;
struct frame *f = haiku_mouse_or_wdesc_frame (b->window);
Mouse_HLInfo *hlinfo = &x_display_list->mouse_highlight;
+ Lisp_Object frame;
if (!f)
continue;
@@ -2946,7 +3007,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
break;
}
- Lisp_Object frame;
XSETFRAME (frame, f);
x_display_list->last_mouse_movement_time = b->time / 1000;
@@ -3062,8 +3122,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
&& (!NILP (focus_follows_mouse)
|| f == SELECTED_FRAME ()))
{
- inev.kind = SELECT_WINDOW_EVENT;
- inev.frame_or_window = window;
+ inev2.kind = SELECT_WINDOW_EVENT;
+ inev2.frame_or_window = window;
}
last_mouse_window = window;
@@ -3078,9 +3138,32 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
if (!NILP (help_echo_string)
|| !NILP (previous_help_echo_string))
do_help = 1;
+
+ if (b->dnd_message)
+ {
+ /* It doesn't make sense to show tooltips when
+ another program is dragging stuff over us. */
+
+ do_help = -1;
+
+ if (!be_drag_and_drop_in_progress ())
+ {
+ inev.kind = DRAG_N_DROP_EVENT;
+ inev.arg = Qlambda;
+
+ XSETINT (inev.x, b->x);
+ XSETINT (inev.y, b->y);
+ XSETFRAME (inev.frame_or_window, f);
+ }
+ else
+ haiku_note_drag_motion ();
+
+ break;
+ }
}
- need_flush = FRAME_DIRTY_P (f);
+ if (FRAME_DIRTY_P (f))
+ need_flush = 1;
break;
}
case BUTTON_UP:
@@ -3130,7 +3213,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
int y = b->y;
window = window_from_coordinates (f, x, y, 0, true, true);
- tool_bar_p = EQ (window, f->tool_bar_window);
+ tool_bar_p = (EQ (window, f->tool_bar_window)
+ && (type != BUTTON_UP
+ || f->last_tool_bar_item != -1));
if (tool_bar_p)
{
@@ -3215,16 +3300,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
if (!f)
continue;
- if (FRAME_OUTPUT_DATA (f)->pending_zoom_x != b->x ||
- FRAME_OUTPUT_DATA (f)->pending_zoom_y != b->y)
- FRAME_OUTPUT_DATA (f)->zoomed_p = 0;
- else
- {
- FRAME_OUTPUT_DATA (f)->zoomed_p = 1;
- FRAME_OUTPUT_DATA (f)->pending_zoom_x = INT_MIN;
- FRAME_OUTPUT_DATA (f)->pending_zoom_y = INT_MIN;
- }
-
if (FRAME_PARENT_FRAME (f))
haiku_coords_from_parent (f, &b->x, &b->y);
@@ -3536,12 +3611,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
if (!f)
continue;
- FRAME_OUTPUT_DATA (f)->pending_zoom_height = b->height;
- FRAME_OUTPUT_DATA (f)->pending_zoom_width = b->width;
- FRAME_OUTPUT_DATA (f)->pending_zoom_x = b->x;
- FRAME_OUTPUT_DATA (f)->pending_zoom_y = b->y;
-
- FRAME_OUTPUT_DATA (f)->zoomed_p = 1;
+ FRAME_OUTPUT_DATA (f)->zoomed_p = b->zoomed;
haiku_make_fullscreen_consistent (f);
break;
}
@@ -3787,13 +3857,10 @@ haiku_fullscreen (struct frame *f)
return;
if (f->want_fullscreen == FULLSCREEN_MAXIMIZED)
- {
- EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0);
- BWindow_zoom (FRAME_HAIKU_WINDOW (f));
- }
+ BWindow_zoom (FRAME_HAIKU_WINDOW (f));
else if (f->want_fullscreen == FULLSCREEN_BOTH)
EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1);
- else if (f->want_fullscreen == FULLSCREEN_NONE)
+ else
{
EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0);
EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f));
@@ -3908,6 +3975,37 @@ haiku_term_init (void)
dpyinfo->smallest_char_width = 1;
gui_init_fringe (terminal->rif);
+
+#define ASSIGN_CURSOR(cursor, be_cursor) (dpyinfo->cursor = be_cursor)
+ ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ());
+ ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ());
+ ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ());
+ ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ());
+ ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ());
+ ASSIGN_CURSOR (horizontal_drag_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST));
+ ASSIGN_CURSOR (vertical_drag_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH));
+ ASSIGN_CURSOR (left_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_WEST));
+ ASSIGN_CURSOR (top_left_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST));
+ ASSIGN_CURSOR (top_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH));
+ ASSIGN_CURSOR (top_right_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST));
+ ASSIGN_CURSOR (right_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_EAST));
+ ASSIGN_CURSOR (bottom_right_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST));
+ ASSIGN_CURSOR (bottom_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_SOUTH));
+ ASSIGN_CURSOR (bottom_left_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST));
+ ASSIGN_CURSOR (no_cursor,
+ BCursor_from_id (CURSOR_ID_NO_CURSOR));
+#undef ASSIGN_CURSOR
+
unblock_input ();
return dpyinfo;
diff --git a/src/haikuterm.h b/src/haikuterm.h
index 65fd51e237c..586df285751 100644
--- a/src/haikuterm.h
+++ b/src/haikuterm.h
@@ -107,6 +107,23 @@ struct haiku_display_info
Time last_mouse_movement_time;
Window root_window;
+
+ Emacs_Cursor text_cursor;
+ Emacs_Cursor nontext_cursor;
+ Emacs_Cursor modeline_cursor;
+ Emacs_Cursor hand_cursor;
+ Emacs_Cursor hourglass_cursor;
+ Emacs_Cursor horizontal_drag_cursor;
+ Emacs_Cursor vertical_drag_cursor;
+ Emacs_Cursor left_edge_cursor;
+ Emacs_Cursor top_left_corner_cursor;
+ Emacs_Cursor top_edge_cursor;
+ Emacs_Cursor top_right_corner_cursor;
+ Emacs_Cursor right_edge_cursor;
+ Emacs_Cursor bottom_right_corner_cursor;
+ Emacs_Cursor bottom_edge_cursor;
+ Emacs_Cursor bottom_left_corner_cursor;
+ Emacs_Cursor no_cursor;
};
struct haiku_output
@@ -150,11 +167,6 @@ struct haiku_output
int menu_up_to_date_p;
int zoomed_p;
- int pending_zoom_x;
- int pending_zoom_y;
- int pending_zoom_width;
- int pending_zoom_height;
-
int menu_bar_open_p;
struct font *font;
@@ -180,6 +192,7 @@ extern struct haiku_display_info *x_display_list;
extern struct font_driver const haikufont_driver;
extern Lisp_Object tip_frame;
+extern struct frame *haiku_dnd_frame;
struct scroll_bar
{
@@ -281,6 +294,7 @@ extern void haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel);
extern Lisp_Object haiku_menu_show (struct frame *f, int x, int y, int menu_flags,
Lisp_Object title, const char **error_name);
extern Lisp_Object haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents);
+extern void haiku_note_drag_motion (void);
extern void initialize_frame_menubar (struct frame *f);
diff --git a/src/image.c b/src/image.c
index c412dc90296..45de7ae83d3 100644
--- a/src/image.c
+++ b/src/image.c
@@ -1796,13 +1796,50 @@ search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash,
}
+/* Filter out image elements that don't affect display, but will
+ disrupt finding the image in the cache. This should perhaps be
+ user-configurable, but for now it's hard-coded (but new elements
+ can be added at will). */
+static Lisp_Object
+filter_image_spec (Lisp_Object spec)
+{
+ Lisp_Object out = Qnil;
+
+ /* Skip past the `image' element. */
+ if (CONSP (spec))
+ spec = XCDR (spec);
+
+ while (CONSP (spec))
+ {
+ Lisp_Object key = XCAR (spec);
+ spec = XCDR (spec);
+ if (CONSP (spec))
+ {
+ Lisp_Object value = XCAR (spec);
+ spec = XCDR (spec);
+
+ /* Some animation-related data doesn't affect display, but
+ breaks the image cache. Filter those out. */
+ if (!(EQ (key, QCanimate_buffer)
+ || EQ (key, QCanimate_tardiness)
+ || EQ (key, QCanimate_position)
+ || EQ (key, QCanimate_multi_frame_data)))
+ {
+ out = Fcons (value, out);
+ out = Fcons (key, out);
+ }
+ }
+ }
+ return out;
+}
+
/* Search frame F for an image with spec SPEC, and free it. */
static void
uncache_image (struct frame *f, Lisp_Object spec)
{
struct image *img;
- EMACS_UINT hash = sxhash (spec);
+ EMACS_UINT hash = sxhash (filter_image_spec (spec));
/* Because the background colors are based on the current face, we
can have multiple copies of an image with the same spec. We want
@@ -2643,7 +2680,7 @@ lookup_image (struct frame *f, Lisp_Object spec, int face_id)
eassert (valid_image_p (spec));
/* Look up SPEC in the hash table of the image cache. */
- hash = sxhash (spec);
+ hash = sxhash (filter_image_spec (spec));
img = search_image_cache (f, spec, hash, foreground, background,
font_size, font_family, false);
if (img && img->load_failed_p)
@@ -2782,6 +2819,92 @@ cache_image (struct frame *f, struct image *img)
}
+#if defined (HAVE_WEBP) || defined (HAVE_GIF)
+
+/* To speed animations up, we keep a cache (based on EQ-ness of the
+ image spec/object) where we put the animator iterator. */
+
+struct anim_cache
+{
+ Lisp_Object spec;
+ /* For webp, this will be an iterator, and for libgif, a gif handle. */
+ void *handle;
+ /* If we need to maintain temporary data of some sort. */
+ void *temp;
+ /* A function to call to free the handle. */
+ void (*destructor) (void *);
+ int index, width, height, frames;
+ struct timespec update_time;
+ struct anim_cache *next;
+};
+
+static struct anim_cache *anim_cache = NULL;
+
+static struct anim_cache *
+anim_create_cache (Lisp_Object spec)
+{
+ struct anim_cache *cache = xmalloc (sizeof (struct anim_cache));
+ cache->handle = NULL;
+ cache->temp = NULL;
+
+ cache->index = -1;
+ cache->next = NULL;
+ cache->spec = spec;
+ return cache;
+}
+
+/* Discard cached images that haven't been used for a minute. */
+static void
+anim_prune_animation_cache (void)
+{
+ struct anim_cache **pcache = &anim_cache;
+ struct timespec old = timespec_sub (current_timespec (),
+ make_timespec (60, 0));
+
+ while (*pcache)
+ {
+ struct anim_cache *cache = *pcache;
+ if (timespec_cmp (old, cache->update_time) <= 0)
+ pcache = &cache->next;
+ else
+ {
+ if (cache->handle)
+ cache->destructor (cache);
+ if (cache->temp)
+ xfree (cache->temp);
+ *pcache = cache->next;
+ xfree (cache);
+ }
+ }
+}
+
+static struct anim_cache *
+anim_get_animation_cache (Lisp_Object spec)
+{
+ struct anim_cache *cache;
+ struct anim_cache **pcache = &anim_cache;
+
+ anim_prune_animation_cache ();
+
+ while (1)
+ {
+ cache = *pcache;
+ if (! cache)
+ {
+ *pcache = cache = anim_create_cache (spec);
+ break;
+ }
+ if (EQ (spec, cache->spec))
+ break;
+ pcache = &cache->next;
+ }
+
+ cache->update_time = current_timespec ();
+ return cache;
+}
+
+#endif /* HAVE_WEBP || HAVE_GIF */
+
/* Call FN on every image in the image cache of frame F. Used to mark
Lisp Objects in the image cache. */
@@ -2808,6 +2931,11 @@ mark_image_cache (struct image_cache *c)
if (c->images[i])
mark_image (c->images[i]);
}
+
+#if defined HAVE_WEBP || defined HAVE_GIF
+ for (struct anim_cache *cache = anim_cache; cache; cache = cache->next)
+ mark_object (cache->spec);
+#endif
}
@@ -8665,116 +8793,191 @@ static const int interlace_increment[] = {8, 8, 4, 2};
#define GIF_LOCAL_DESCRIPTOR_EXTENSION 249
+static void
+gif_destroy (struct anim_cache* cache)
+{
+ int gif_err;
+ gif_close (cache->handle, &gif_err);
+}
+
static bool
gif_load (struct frame *f, struct image *img)
{
int rc, width, height, x, y, i, j;
ColorMapObject *gif_color_map;
- GifFileType *gif;
+ GifFileType *gif = NULL;
gif_memory_source memsrc;
Lisp_Object specified_bg = image_spec_value (img->spec, QCbackground, NULL);
Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL);
Lisp_Object specified_data = image_spec_value (img->spec, QCdata, NULL);
- EMACS_INT idx;
+ unsigned long *pixmap = NULL;
+ EMACS_INT idx = -1;
int gif_err;
+ struct anim_cache* cache = NULL;
+ /* Which sub-image are we to display? */
+ Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL);
- if (NILP (specified_data))
+ idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0;
+
+ if (!NILP (image_number))
{
- Lisp_Object file = image_find_image_file (specified_file);
- if (!STRINGP (file))
+ /* If this is an animated image, create a cache for it. */
+ cache = anim_get_animation_cache (img->spec);
+ /* We have an old cache entry, so use it. */
+ if (cache->handle)
{
- image_error ("Cannot find image file `%s'", specified_file);
- return false;
+ gif = cache->handle;
+ pixmap = cache->temp;
+ /* We're out of sync, so start from the beginning. */
+ if (cache->index != idx - 1)
+ cache->index = -1;
}
+ }
- Lisp_Object encoded_file = ENCODE_FILE (file);
+ /* If we don't have a cached entry, read the image. */
+ if (! gif)
+ {
+ if (NILP (specified_data))
+ {
+ Lisp_Object file = image_find_image_file (specified_file);
+ if (!STRINGP (file))
+ {
+ image_error ("Cannot find image file `%s'", specified_file);
+ return false;
+ }
+
+ Lisp_Object encoded_file = ENCODE_FILE (file);
#ifdef WINDOWSNT
- encoded_file = ansi_encode_filename (encoded_file);
+ encoded_file = ansi_encode_filename (encoded_file);
#endif
- /* Open the GIF file. */
+ /* Open the GIF file. */
#if GIFLIB_MAJOR < 5
- gif = DGifOpenFileName (SSDATA (encoded_file));
+ gif = DGifOpenFileName (SSDATA (encoded_file));
#else
- gif = DGifOpenFileName (SSDATA (encoded_file), &gif_err);
+ gif = DGifOpenFileName (SSDATA (encoded_file), &gif_err);
#endif
- if (gif == NULL)
- {
+ if (gif == NULL)
+ {
#if HAVE_GIFERRORSTRING
- const char *errstr = GifErrorString (gif_err);
- if (errstr)
- image_error ("Cannot open `%s': %s", file, build_string (errstr));
- else
+ const char *errstr = GifErrorString (gif_err);
+ if (errstr)
+ image_error ("Cannot open `%s': %s", file,
+ build_string (errstr));
+ else
#endif
- image_error ("Cannot open `%s'", file);
- return false;
+ image_error ("Cannot open `%s'", file);
+ return false;
+ }
}
- }
- else
- {
- if (!STRINGP (specified_data))
+ else
{
- image_error ("Invalid image data `%s'", specified_data);
- return false;
- }
+ if (!STRINGP (specified_data))
+ {
+ image_error ("Invalid image data `%s'", specified_data);
+ return false;
+ }
- /* Read from memory! */
- current_gif_memory_src = &memsrc;
- memsrc.bytes = SDATA (specified_data);
- memsrc.len = SBYTES (specified_data);
- memsrc.index = 0;
+ /* Read from memory! */
+ current_gif_memory_src = &memsrc;
+ memsrc.bytes = SDATA (specified_data);
+ memsrc.len = SBYTES (specified_data);
+ memsrc.index = 0;
#if GIFLIB_MAJOR < 5
- gif = DGifOpen (&memsrc, gif_read_from_memory);
+ gif = DGifOpen (&memsrc, gif_read_from_memory);
#else
- gif = DGifOpen (&memsrc, gif_read_from_memory, &gif_err);
+ gif = DGifOpen (&memsrc, gif_read_from_memory, &gif_err);
+#endif
+ if (!gif)
+ {
+#if HAVE_GIFERRORSTRING
+ const char *errstr = GifErrorString (gif_err);
+ if (errstr)
+ image_error ("Cannot open memory source `%s': %s",
+ img->spec, build_string (errstr));
+ else
#endif
- if (!gif)
+ image_error ("Cannot open memory source `%s'", img->spec);
+ return false;
+ }
+ }
+
+ /* Before reading entire contents, check the declared image size. */
+ if (!check_image_size (f, gif->SWidth, gif->SHeight))
+ {
+ image_size_error ();
+ goto gif_error;
+ }
+
+ /* Read entire contents. */
+ rc = DGifSlurp (gif);
+ if (rc == GIF_ERROR || gif->ImageCount <= 0)
{
#if HAVE_GIFERRORSTRING
- const char *errstr = GifErrorString (gif_err);
+ const char *errstr = GifErrorString (gif->Error);
if (errstr)
- image_error ("Cannot open memory source `%s': %s",
- img->spec, build_string (errstr));
+ if (NILP (specified_data))
+ image_error ("Error reading `%s' (%s)", img->spec,
+ build_string (errstr));
+ else
+ image_error ("Error reading GIF data: %s",
+ build_string (errstr));
else
#endif
- image_error ("Cannot open memory source `%s'", img->spec);
- return false;
+ if (NILP (specified_data))
+ image_error ("Error reading `%s'", img->spec);
+ else
+ image_error ("Error reading GIF data");
+ goto gif_error;
}
- }
- /* Before reading entire contents, check the declared image size. */
- if (!check_image_size (f, gif->SWidth, gif->SHeight))
+ width = img->width = gif->SWidth;
+ height = img->height = gif->SHeight;
+
+ /* Check that the selected subimages fit. It's not clear whether
+ the GIF spec requires this, but Emacs can crash if they don't fit. */
+ for (j = 0; j < gif->ImageCount; ++j)
+ {
+ struct SavedImage *subimage = gif->SavedImages + j;
+ int subimg_width = subimage->ImageDesc.Width;
+ int subimg_height = subimage->ImageDesc.Height;
+ int subimg_top = subimage->ImageDesc.Top;
+ int subimg_left = subimage->ImageDesc.Left;
+ if (subimg_width < 0
+ || subimg_height < 0
+ || subimg_top < 0
+ || subimg_left < 0
+ || subimg_top + subimg_height > height
+ || subimg_left + subimg_width > width)
+ {
+ image_error ("Subimage does not fit in image");
+ goto gif_error;
+ }
+ }
+ }
+ else
{
- image_size_error ();
- goto gif_error;
+ /* Cached image; set data. */
+ width = img->width = gif->SWidth;
+ height = img->height = gif->SHeight;
}
- /* Read entire contents. */
- rc = DGifSlurp (gif);
- if (rc == GIF_ERROR || gif->ImageCount <= 0)
+ if (idx < 0 || idx >= gif->ImageCount)
{
- if (NILP (specified_data))
- image_error ("Error reading `%s'", img->spec);
- else
- image_error ("Error reading GIF data");
+ image_error ("Invalid image number `%s' in image `%s'",
+ make_fixnum (idx), img->spec);
goto gif_error;
}
- /* Which sub-image are we to display? */
- {
- Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL);
- idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0;
- if (idx < 0 || idx >= gif->ImageCount)
- {
- image_error ("Invalid image number `%s' in image `%s'",
- image_number, img->spec);
- goto gif_error;
- }
- }
-
- width = img->width = gif->SWidth;
- height = img->height = gif->SHeight;
+ /* It's an animated image, so initalize the cache. */
+ if (cache && !cache->handle)
+ {
+ cache->handle = gif;
+ cache->destructor = (void (*)(void *)) &gif_destroy;
+ cache->width = width;
+ cache->height = height;
+ }
img->corners[TOP_CORNER] = gif->SavedImages[0].ImageDesc.Top;
img->corners[LEFT_CORNER] = gif->SavedImages[0].ImageDesc.Left;
@@ -8789,29 +8992,20 @@ gif_load (struct frame *f, struct image *img)
goto gif_error;
}
- /* Check that the selected subimages fit. It's not clear whether
- the GIF spec requires this, but Emacs can crash if they don't fit. */
- for (j = 0; j <= idx; ++j)
- {
- struct SavedImage *subimage = gif->SavedImages + j;
- int subimg_width = subimage->ImageDesc.Width;
- int subimg_height = subimage->ImageDesc.Height;
- int subimg_top = subimage->ImageDesc.Top;
- int subimg_left = subimage->ImageDesc.Left;
- if (! (subimg_width >= 0 && subimg_height >= 0
- && 0 <= subimg_top && subimg_top <= height - subimg_height
- && 0 <= subimg_left && subimg_left <= width - subimg_width))
- {
- image_error ("Subimage does not fit in image");
- goto gif_error;
- }
- }
-
/* Create the X image and pixmap. */
Emacs_Pix_Container ximg;
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
goto gif_error;
+ /* We construct the (possibly composited animated) image in this
+ buffer. */
+ if (!pixmap)
+ {
+ pixmap = xmalloc (width * height * sizeof (unsigned long));
+ if (cache)
+ cache->temp = pixmap;
+ }
+
/* Clear the part of the screen image not covered by the image.
Full animated GIF support requires more here (see the gif89 spec,
disposal methods). Let's simply assume that the part not covered
@@ -8826,29 +9020,25 @@ gif_load (struct frame *f, struct image *img)
frame_bg = lookup_rgb_color (f, color.red, color.green, color.blue);
}
#endif /* USE_CAIRO */
+
for (y = 0; y < img->corners[TOP_CORNER]; ++y)
for (x = 0; x < width; ++x)
- PUT_PIXEL (ximg, x, y, frame_bg);
+ *(pixmap + x + y * width) = frame_bg;
for (y = img->corners[BOT_CORNER]; y < height; ++y)
for (x = 0; x < width; ++x)
- PUT_PIXEL (ximg, x, y, frame_bg);
+ *(pixmap + x + y * width) = frame_bg;
for (y = img->corners[TOP_CORNER]; y < img->corners[BOT_CORNER]; ++y)
{
for (x = 0; x < img->corners[LEFT_CORNER]; ++x)
- PUT_PIXEL (ximg, x, y, frame_bg);
+ *(pixmap + x + y * width) = frame_bg;
for (x = img->corners[RIGHT_CORNER]; x < width; ++x)
- PUT_PIXEL (ximg, x, y, frame_bg);
+ *(pixmap + x + y * width) = frame_bg;
}
/* Read the GIF image into the X image. */
- /* FIXME: With the current implementation, loading an animated gif
- is quadratic in the number of animation frames, since each frame
- is a separate struct image. We must provide a way for a single
- gif_load call to construct and save all animation frames. */
-
init_color_table ();
unsigned long bgcolor UNINIT;
@@ -8863,7 +9053,18 @@ gif_load (struct frame *f, struct image *img)
#endif
}
- for (j = 0; j <= idx; ++j)
+ int start_frame = 0;
+
+ /* We have animation data in the cache. */
+ if (cache && cache->temp)
+ {
+ start_frame = cache->index + 1;
+ if (start_frame > idx)
+ start_frame = 0;
+ cache->index = idx;
+ }
+
+ for (j = start_frame; j <= idx; ++j)
{
/* We use a local variable `raster' here because RasterBits is a
char *, which invites problems with bytes >= 0x80. */
@@ -8914,6 +9115,14 @@ gif_load (struct frame *f, struct image *img)
if (disposal == DISPOSAL_UNSPECIFIED)
disposal = DISPOSE_DO_NOT;
+ /* This is not quite correct -- the specification is unclear,
+ but I think we're supposed to restore to the frame before the
+ previous frame? And we don't have that data at this point.
+ But DISPOSE_DO_NOT is less wrong than substituting the
+ background, so do that for now. */
+ if (disposal == DISPOSE_PREVIOUS)
+ disposal = DISPOSE_DO_NOT;
+
gif_color_map = subimage->ImageDesc.ColorMap;
if (!gif_color_map)
gif_color_map = gif->SColorMap;
@@ -8953,8 +9162,8 @@ gif_load (struct frame *f, struct image *img)
int c = raster[y * subimg_width + x];
if (transparency_color_index != c || disposal != DISPOSE_DO_NOT)
{
- PUT_PIXEL (ximg, x + subimg_left, row + subimg_top,
- pixel_colors[c]);
+ *(pixmap + x + subimg_left + (y + subimg_top) * width) =
+ pixel_colors[c];
}
}
}
@@ -8967,13 +9176,19 @@ gif_load (struct frame *f, struct image *img)
int c = raster[y * subimg_width + x];
if (transparency_color_index != c || disposal != DISPOSE_DO_NOT)
{
- PUT_PIXEL (ximg, x + subimg_left, y + subimg_top,
- pixel_colors[c]);
+ *(pixmap + x + subimg_left + (y + subimg_top) * width) =
+ pixel_colors[c];
}
}
}
}
+ /* We now have the complete image (possibly composed from a series
+ of animated frames) in pixmap. Put it into ximg. */
+ for (y = 0; y < height; ++y)
+ for (x = 0; x < width; ++x)
+ PUT_PIXEL (ximg, x, y, *(pixmap + x + y * width));
+
#ifdef COLOR_TABLE_SUPPORT
img->colors = colors_in_color_table (&img->ncolors);
free_color_table ();
@@ -9002,11 +9217,11 @@ gif_load (struct frame *f, struct image *img)
}
}
img->lisp_data = list2 (Qextension_data, img->lisp_data);
- if (delay)
- img->lisp_data
- = Fcons (Qdelay,
- Fcons (make_float (delay / 100.0),
- img->lisp_data));
+ img->lisp_data
+ = Fcons (Qdelay,
+ /* Default GIF delay is 1/15th of a second. */
+ Fcons (make_float (delay? delay / 100.0: 1.0 / 15),
+ img->lisp_data));
}
if (gif->ImageCount > 1)
@@ -9014,17 +9229,22 @@ gif_load (struct frame *f, struct image *img)
Fcons (make_fixnum (gif->ImageCount),
img->lisp_data));
- if (gif_close (gif, &gif_err) == GIF_ERROR)
+ if (!cache)
{
+ if (pixmap)
+ xfree (pixmap);
+ if (gif_close (gif, &gif_err) == GIF_ERROR)
+ {
#if HAVE_GIFERRORSTRING
- char const *error_text = GifErrorString (gif_err);
+ char const *error_text = GifErrorString (gif_err);
- if (error_text)
- image_error ("Error closing `%s': %s",
- img->spec, build_string (error_text));
- else
+ if (error_text)
+ image_error ("Error closing `%s': %s",
+ img->spec, build_string (error_text));
+ else
#endif
- image_error ("Error closing `%s'", img->spec);
+ image_error ("Error closing `%s'", img->spec);
+ }
}
/* Maybe fill in the background field while we have ximg handy. */
@@ -9038,7 +9258,14 @@ gif_load (struct frame *f, struct image *img)
return true;
gif_error:
+ if (pixmap)
+ xfree (pixmap);
gif_close (gif, NULL);
+ if (cache)
+ {
+ cache->handle = NULL;
+ cache->temp = NULL;
+ }
return false;
}
@@ -9053,6 +9280,7 @@ gif_load (struct frame *f, struct image *img)
***********************************************************************/
#include "webp/decode.h"
+#include "webp/demux.h"
/* Indices of image specification fields in webp_format, below. */
@@ -9067,6 +9295,7 @@ enum webp_keyword_index
WEBP_ALGORITHM,
WEBP_HEURISTIC_MASK,
WEBP_MASK,
+ WEBP_INDEX,
WEBP_BACKGROUND,
WEBP_LAST
};
@@ -9085,6 +9314,7 @@ static const struct image_keyword webp_format[WEBP_LAST] =
{":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
{":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
{":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
+ {":index", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
{":background", IMAGE_STRING_OR_NIL_VALUE, 0}
};
@@ -9117,20 +9347,41 @@ DEF_DLL_FN (VP8StatusCode, WebPGetFeaturesInternal,
DEF_DLL_FN (uint8_t *, WebPDecodeRGBA, (const uint8_t *, size_t, int *, int *));
DEF_DLL_FN (uint8_t *, WebPDecodeRGB, (const uint8_t *, size_t, int *, int *));
DEF_DLL_FN (void, WebPFree, (void *));
+DEF_DLL_FN (uint32_t, WebPDemuxGetI, (const WebPDemuxer *, WebPFormatFeature));
+DEF_DLL_FN (WebPDemuxer *, WebPDemuxInternal,
+ (const WebPData *, int, WebPDemuxState *, int));
+DEF_DLL_FN (void, WebPDemuxDelete, (WebPDemuxer *));
+DEF_DLL_FN (int, WebPAnimDecoderGetNext,
+ (WebPAnimDecoder *, uint8_t **, int *));
+DEF_DLL_FN (WebPAnimDecoder *, WebPAnimDecoderNewInternal,
+ (const WebPData *, const WebPAnimDecoderOptions *, int));
+DEF_DLL_FN (int, WebPAnimDecoderOptionsInitInternal,
+ (WebPAnimDecoderOptions *, int));
+DEF_DLL_FN (int, WebPAnimDecoderHasMoreFrames, (const WebPAnimDecoder *));
+DEF_DLL_FN (void, WebPAnimDecoderDelete, (WebPAnimDecoder *));
static bool
init_webp_functions (void)
{
- HMODULE library;
+ HMODULE library1, library2;
- if (!(library = w32_delayed_load (Qwebp)))
+ if (!((library1 = w32_delayed_load (Qwebp))
+ && (library2 = w32_delayed_load (Qwebpdemux))))
return false;
- LOAD_DLL_FN (library, WebPGetInfo);
- LOAD_DLL_FN (library, WebPGetFeaturesInternal);
- LOAD_DLL_FN (library, WebPDecodeRGBA);
- LOAD_DLL_FN (library, WebPDecodeRGB);
- LOAD_DLL_FN (library, WebPFree);
+ LOAD_DLL_FN (library1, WebPGetInfo);
+ LOAD_DLL_FN (library1, WebPGetFeaturesInternal);
+ LOAD_DLL_FN (library1, WebPDecodeRGBA);
+ LOAD_DLL_FN (library1, WebPDecodeRGB);
+ LOAD_DLL_FN (library1, WebPFree);
+ LOAD_DLL_FN (library2, WebPDemuxGetI);
+ LOAD_DLL_FN (library2, WebPDemuxInternal);
+ LOAD_DLL_FN (library2, WebPDemuxDelete);
+ LOAD_DLL_FN (library2, WebPAnimDecoderGetNext);
+ LOAD_DLL_FN (library2, WebPAnimDecoderNewInternal);
+ LOAD_DLL_FN (library2, WebPAnimDecoderOptionsInitInternal);
+ LOAD_DLL_FN (library2, WebPAnimDecoderHasMoreFrames);
+ LOAD_DLL_FN (library2, WebPAnimDecoderDelete);
return true;
}
@@ -9139,6 +9390,14 @@ init_webp_functions (void)
#undef WebPDecodeRGBA
#undef WebPDecodeRGB
#undef WebPFree
+#undef WebPDemuxGetI
+#undef WebPDemux
+#undef WebPDemuxDelete
+#undef WebPAnimDecoderGetNext
+#undef WebPAnimDecoderNew
+#undef WebPAnimDecoderOptionsInit
+#undef WebPAnimDecoderHasMoreFrames
+#undef WebPAnimDecoderDelete
#define WebPGetInfo fn_WebPGetInfo
#define WebPGetFeatures(d,s,f) \
@@ -9146,9 +9405,26 @@ init_webp_functions (void)
#define WebPDecodeRGBA fn_WebPDecodeRGBA
#define WebPDecodeRGB fn_WebPDecodeRGB
#define WebPFree fn_WebPFree
+#define WebPDemuxGetI fn_WebPDemuxGetI
+#define WebPDemux(d) \
+ fn_WebPDemuxInternal(d,0,NULL,WEBP_DEMUX_ABI_VERSION)
+#define WebPDemuxDelete fn_WebPDemuxDelete
+#define WebPAnimDecoderGetNext fn_WebPAnimDecoderGetNext
+#define WebPAnimDecoderNew(d,o) \
+ fn_WebPAnimDecoderNewInternal(d,o,WEBP_DEMUX_ABI_VERSION)
+#define WebPAnimDecoderOptionsInit(o) \
+ fn_WebPAnimDecoderOptionsInitInternal(o,WEBP_DEMUX_ABI_VERSION)
+#define WebPAnimDecoderHasMoreFrames fn_WebPAnimDecoderHasMoreFrames
+#define WebPAnimDecoderDelete fn_WebPAnimDecoderDelete
#endif /* WINDOWSNT */
+static void
+webp_destroy (struct anim_cache* cache)
+{
+ WebPAnimDecoderDelete (cache->handle);
+}
+
/* Load WebP image IMG for use on frame F. Value is true if
successful. */
@@ -9158,6 +9434,9 @@ webp_load (struct frame *f, struct image *img)
ptrdiff_t size = 0;
uint8_t *contents;
Lisp_Object file = Qnil;
+ int frames = 0;
+ double delay = 0;
+ WebPAnimDecoder* anim = NULL;
/* Open the WebP file. */
Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL);
@@ -9201,6 +9480,9 @@ webp_load (struct frame *f, struct image *img)
goto webp_error1;
}
+ Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL);
+ ptrdiff_t idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0;
+
/* Get WebP features. */
WebPBitstreamFeatures features;
VP8StatusCode result = WebPGetFeatures (contents, size, &features);
@@ -9224,19 +9506,90 @@ webp_load (struct frame *f, struct image *img)
goto webp_error1;
}
- /* Decode WebP data. */
- uint8_t *decoded;
+ uint8_t *decoded = NULL;
int width, height;
- if (features.has_alpha)
- /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */
- decoded = WebPDecodeRGBA (contents, size, &width, &height);
+
+ if (features.has_animation)
+ {
+ /* Animated image. */
+ int timestamp;
+
+ struct anim_cache* cache = anim_get_animation_cache (img->spec);
+ /* Get the next frame from the animation cache. */
+ if (cache->handle && cache->index == idx - 1)
+ {
+ WebPAnimDecoderGetNext (cache->handle, &decoded, &timestamp);
+ delay = timestamp;
+ cache->index++;
+ anim = cache->handle;
+ width = cache->width;
+ height = cache->height;
+ frames = cache->frames;
+ }
+ else
+ {
+ /* Start a new cache entry. */
+ if (cache->handle)
+ WebPAnimDecoderDelete (cache->handle);
+
+ WebPData webp_data;
+ if (NILP (specified_data))
+ /* If we got the data from a file, then we don't need to
+ copy the data. */
+ webp_data.bytes = cache->temp = contents;
+ else
+ /* We got the data from a string, so copy it over so that
+ it doesn't get garbage-collected. */
+ {
+ webp_data.bytes = xmalloc (size);
+ memcpy ((void*) webp_data.bytes, contents, size);
+ }
+ /* In any case, we release the allocated memory when we
+ purge the anim cache. */
+ webp_data.size = size;
+
+ /* Get the width/height of the total image. */
+ WebPDemuxer* demux = WebPDemux (&webp_data);
+ cache->width = width = WebPDemuxGetI (demux, WEBP_FF_CANVAS_WIDTH);
+ cache->height = height = WebPDemuxGetI (demux,
+ WEBP_FF_CANVAS_HEIGHT);
+ cache->frames = frames = WebPDemuxGetI (demux, WEBP_FF_FRAME_COUNT);
+ cache->destructor = (void (*)(void *)) webp_destroy;
+ WebPDemuxDelete (demux);
+
+ WebPAnimDecoderOptions dec_options;
+ WebPAnimDecoderOptionsInit (&dec_options);
+ anim = WebPAnimDecoderNew (&webp_data, &dec_options);
+
+ cache->handle = anim;
+ cache->index = idx;
+
+ while (WebPAnimDecoderHasMoreFrames (anim)) {
+ WebPAnimDecoderGetNext (anim, &decoded, &timestamp);
+ /* Each frame has its own delay, but we don't really support
+ that. So just use the delay from the first frame. */
+ if (delay == 0)
+ delay = timestamp;
+ /* Stop when we get to the desired index. */
+ if (idx-- == 0)
+ break;
+ }
+ }
+ }
else
- /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */
- decoded = WebPDecodeRGB (contents, size, &width, &height);
+ {
+ /* Non-animated image. */
+ if (features.has_alpha)
+ /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */
+ decoded = WebPDecodeRGBA (contents, size, &width, &height);
+ else
+ /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */
+ decoded = WebPDecodeRGB (contents, size, &width, &height);
+ }
if (!decoded)
{
- image_error ("Error when interpreting WebP image data");
+ image_error ("Error when decoding WebP image data");
goto webp_error1;
}
@@ -9255,7 +9608,8 @@ webp_load (struct frame *f, struct image *img)
/* Create an image and pixmap serving as mask if the WebP image
contains an alpha channel. */
if (features.has_alpha
- && !image_create_x_image_and_pixmap (f, img, width, height, 1, &mask_img, true))
+ && !image_create_x_image_and_pixmap (f, img, width, height, 1,
+ &mask_img, true))
{
image_destroy_x_image (ximg);
image_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP);
@@ -9265,6 +9619,13 @@ webp_load (struct frame *f, struct image *img)
/* Fill the X image and mask from WebP data. */
init_color_table ();
+ img->corners[TOP_CORNER] = 0;
+ img->corners[LEFT_CORNER] = 0;
+ img->corners[BOT_CORNER]
+ = img->corners[TOP_CORNER] + height;
+ img->corners[RIGHT_CORNER]
+ = img->corners[LEFT_CORNER] + width;
+
uint8_t *p = decoded;
for (int y = 0; y < height; ++y)
{
@@ -9279,7 +9640,7 @@ webp_load (struct frame *f, struct image *img)
image. WebP allows up to 256 levels of partial transparency.
We handle this like with PNG (which see), using the frame's
background color to combine the image with. */
- if (features.has_alpha)
+ if (features.has_alpha || anim)
{
if (mask_img)
PUT_PIXEL (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW : PIX_MASK_RETAIN);
@@ -9310,14 +9671,24 @@ webp_load (struct frame *f, struct image *img)
img->width = width;
img->height = height;
+ /* Return animation data. */
+ img->lisp_data = Fcons (Qcount,
+ Fcons (make_fixnum (frames),
+ img->lisp_data));
+ img->lisp_data = Fcons (Qdelay,
+ Fcons (make_float (delay / 1000),
+ img->lisp_data));
+
/* Clean up. */
- WebPFree (decoded);
- if (NILP (specified_data))
+ if (!anim)
+ WebPFree (decoded);
+ if (NILP (specified_data) && !anim)
xfree (contents);
return true;
webp_error2:
- WebPFree (decoded);
+ if (!anim)
+ WebPFree (decoded);
webp_error1:
if (NILP (specified_data))
@@ -9484,7 +9855,7 @@ imagemagick_filename_hint (Lisp_Object spec, char hint_buffer[MaxTextExtent])
(which is the first one, and then there's a number of images that
follow. If following images have non-transparent colors, these are
composed "on top" of the master image. So, in general, one has to
- compute ann the preceding images to be able to display a particular
+ compute all the preceding images to be able to display a particular
sub-image.
Computing all the preceding images is too slow, so we maintain a
@@ -11524,6 +11895,7 @@ non-numeric, there is no explicit limit on the size of images. */);
#if defined (HAVE_WEBP) || (defined (HAVE_NATIVE_IMAGE_API) \
&& defined (HAVE_HAIKU))
DEFSYM (Qwebp, "webp");
+ DEFSYM (Qwebpdemux, "webpdemux");
add_image_type (Qwebp);
#endif
@@ -11555,6 +11927,12 @@ non-numeric, there is no explicit limit on the size of images. */);
#if HAVE_NATIVE_IMAGE_API
DEFSYM (Qnative_image, "native-image");
+
+# if defined HAVE_NTGUI || defined HAVE_HAIKU
+ DEFSYM (Qbmp, "bmp");
+ add_image_type (Qbmp);
+# endif
+
# ifdef HAVE_NTGUI
DEFSYM (Qgdiplus, "gdiplus");
DEFSYM (Qshlwapi, "shlwapi");
@@ -11577,6 +11955,11 @@ non-numeric, there is no explicit limit on the size of images. */);
defsubr (&Slookup_image);
#endif
+ DEFSYM (QCanimate_buffer, ":animate-buffer");
+ DEFSYM (QCanimate_tardiness, ":animate-tardiness");
+ DEFSYM (QCanimate_position, ":animate-position");
+ DEFSYM (QCanimate_multi_frame_data, ":animate-multi-frame-data");
+
defsubr (&Simage_transforms_p);
DEFVAR_BOOL ("cross-disabled-images", cross_disabled_images,
diff --git a/src/keyboard.c b/src/keyboard.c
index 218f9a86c86..e569f8f34c9 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -336,6 +336,11 @@ static struct timespec timer_idleness_start_time;
static struct timespec timer_last_idleness_start_time;
+/* Predefined strings for core device names. */
+
+static Lisp_Object virtual_core_pointer_name;
+static Lisp_Object virtual_core_keyboard_name;
+
/* Global variable declarations. */
@@ -2460,6 +2465,7 @@ read_char (int commandflag, Lisp_Object map,
else
reread = false;
+ Vlast_event_device = Qnil;
if (CONSP (Vunread_command_events))
{
@@ -3760,6 +3766,7 @@ gen_help_event (Lisp_Object help, Lisp_Object frame, Lisp_Object window,
Lisp_Object object, ptrdiff_t pos)
{
struct input_event event;
+ EVENT_INIT (event);
event.kind = HELP_EVENT;
event.frame_or_window = frame;
@@ -3777,6 +3784,7 @@ void
kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help)
{
struct input_event event;
+ EVENT_INIT (event);
event.kind = HELP_EVENT;
event.frame_or_window = frame;
@@ -4006,6 +4014,41 @@ kbd_buffer_get_event (KBOARD **kbp,
}
break;
+#ifdef HAVE_X_WINDOWS
+ case UNSUPPORTED_DROP_EVENT:
+ {
+ struct frame *f;
+
+ kbd_fetch_ptr = next_kbd_event (event);
+ input_pending = readable_events (0);
+
+ f = XFRAME (event->ie.frame_or_window);
+
+ if (!FRAME_LIVE_P (f))
+ break;
+
+ if (!NILP (Vx_dnd_unsupported_drop_function))
+ {
+ if (!NILP (call6 (Vx_dnd_unsupported_drop_function,
+ XCAR (XCDR (event->ie.arg)), event->ie.x,
+ event->ie.y, XCAR (XCDR (XCDR (event->ie.arg))),
+ make_uint (event->ie.code),
+ event->ie.frame_or_window)))
+ break;
+ }
+
+ x_dnd_do_unsupported_drop (FRAME_DISPLAY_INFO (f),
+ event->ie.frame_or_window,
+ XCAR (event->ie.arg),
+ XCAR (XCDR (event->ie.arg)),
+ (Window) event->ie.code,
+ XFIXNUM (event->ie.x),
+ XFIXNUM (event->ie.y),
+ event->ie.timestamp);
+ break;
+ }
+#endif
+
#ifdef HAVE_EXT_MENU_BAR
case MENU_BAR_ACTIVATE_EVENT:
{
@@ -4083,6 +4126,15 @@ kbd_buffer_get_event (KBOARD **kbp,
obj = make_lispy_switch_frame (frame);
internal_last_event_frame = frame;
+ if (EQ (event->ie.device, Qt))
+ Vlast_event_device = ((event->ie.kind == ASCII_KEYSTROKE_EVENT
+ || event->ie.kind == MULTIBYTE_CHAR_KEYSTROKE_EVENT
+ || event->ie.kind == NON_ASCII_KEYSTROKE_EVENT)
+ ? virtual_core_keyboard_name
+ : virtual_core_pointer_name);
+ else
+ Vlast_event_device = event->ie.device;
+
/* If we didn't decide to make a switch-frame event, go ahead
and build a real event from the queue entry. */
if (NILP (obj))
@@ -4138,6 +4190,10 @@ kbd_buffer_get_event (KBOARD **kbp,
XSETCAR (Fnthcdr (make_fixnum (3),
maybe_event->ie.arg),
make_float (fmod (pinch_angle, 360.0)));
+
+ if (!EQ (maybe_event->ie.device, Qt))
+ Vlast_event_device = maybe_event->ie.device;
+
maybe_event = next_kbd_event (event);
}
}
@@ -4221,12 +4277,13 @@ kbd_buffer_get_event (KBOARD **kbp,
/* Try generating a mouse motion event. */
else if (some_mouse_moved ())
{
- struct frame *f = some_mouse_moved ();
+ struct frame *f, *movement_frame = some_mouse_moved ();
Lisp_Object bar_window;
enum scroll_bar_part part;
Lisp_Object x, y;
Time t;
+ f = movement_frame;
*kbp = current_kboard;
/* Note that this uses F to determine which terminal to look at.
If there is no valid info, it does not store anything
@@ -4261,6 +4318,11 @@ kbd_buffer_get_event (KBOARD **kbp,
return a mouse-motion event. */
if (!NILP (x) && NILP (obj))
obj = make_lispy_movement (f, bar_window, part, x, y, t);
+
+ if (!NILP (obj))
+ Vlast_event_device = (STRINGP (movement_frame->last_mouse_device)
+ ? movement_frame->last_mouse_device
+ : virtual_core_pointer_name);
}
else
/* We were promised by the above while loop that there was
@@ -5247,19 +5309,19 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
Lisp_Object window_or_frame = f
? window_from_coordinates (f, mx, my, &part, true, true)
: Qnil;
+#ifdef HAVE_WINDOW_SYSTEM
bool tool_bar_p = false;
bool menu_bar_p = false;
/* Report mouse events on the tab bar and (on GUI frames) on the
tool bar. */
-#ifdef HAVE_WINDOW_SYSTEM
- if ((WINDOWP (f->tab_bar_window)
- && EQ (window_or_frame, f->tab_bar_window))
+ if (f && ((WINDOWP (f->tab_bar_window)
+ && EQ (window_or_frame, f->tab_bar_window))
#ifndef HAVE_EXT_TOOL_BAR
- || (WINDOWP (f->tool_bar_window)
- && EQ (window_or_frame, f->tool_bar_window))
+ || (WINDOWP (f->tool_bar_window)
+ && EQ (window_or_frame, f->tool_bar_window))
#endif
- )
+ ))
{
/* While 'track-mouse' is neither nil nor t, do not report this
event as something that happened on the tool or tab bar since
@@ -5283,7 +5345,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
window_or_frame = Qnil;
}
- if (FRAME_TERMINAL (f)->toolkit_position_hook)
+ if (f && FRAME_TERMINAL (f)->toolkit_position_hook)
{
FRAME_TERMINAL (f)->toolkit_position_hook (f, mx, my, &menu_bar_p,
&tool_bar_p);
@@ -5524,9 +5586,16 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
}
#endif
}
-
else
- window_or_frame = Qnil;
+ {
+ if (EQ (track_mouse, Qdrag_source))
+ {
+ xret = mx;
+ yret = my;
+ }
+
+ window_or_frame = Qnil;
+ }
return Fcons (window_or_frame,
Fcons (posn,
@@ -11763,6 +11832,10 @@ init_keyboard (void)
interrupt_input_blocked = 0;
pending_signals = false;
+ virtual_core_pointer_name = build_string ("Virtual core pointer");
+ virtual_core_keyboard_name = build_string ("Virtual core keyboard");
+ Vlast_event_device = Qnil;
+
/* This means that command_loop_1 won't try to select anything the first
time through. */
internal_last_event_frame = Qnil;
@@ -12183,6 +12256,12 @@ syms_of_keyboard (void)
staticpro (&poll_timer_time);
#endif
+ virtual_core_pointer_name = Qnil;
+ staticpro (&virtual_core_pointer_name);
+
+ virtual_core_keyboard_name = Qnil;
+ staticpro (&virtual_core_keyboard_name);
+
defsubr (&Scurrent_idle_time);
defsubr (&Sevent_symbol_parse_modifiers);
defsubr (&Sevent_convert_list);
@@ -12381,6 +12460,17 @@ This does not include events generated by keyboard macros. */);
If the last event came from a keyboard macro, this is set to `macro'. */);
Vlast_event_frame = Qnil;
+ DEFVAR_LISP ("last-event-device", Vlast_event_device,
+ doc: /* The name of the input device of the most recently read event.
+When the input extension is being used on X, this is the name of the X
+Input Extension device from which the last event was generated as a
+string. Otherwise, this is "Virtual core keyboard" for keyboard input
+events, and "Virtual core pointer" for other events.
+
+It is nil if the last event did not come from an input device (i.e. it
+came from `unread-command-events' instead). */);
+ Vlast_event_device = Qnil;
+
/* This variable is set up in sysdep.c. */
DEFVAR_LISP ("tty-erase-char", Vtty_erase_char,
doc: /* The ERASE character as set by the user with stty. */);
@@ -12563,12 +12653,15 @@ and the minor mode maps regardless of `overriding-local-map'. */);
doc: /* Non-nil means generate motion events for mouse motion.
The special values `dragging' and `dropping' assert that the mouse
cursor retains its appearance during mouse motion. Any non-nil value
-but `dropping' asserts that motion events always relate to the frame
-where the mouse movement started. The value `dropping' asserts
-that motion events relate to the frame where the mouse cursor is seen
-when generating the event. If there's no such frame, such motion
-events relate to the frame where the mouse movement started. */);
-
+but `dropping' or `drag-source' asserts that motion events always
+relate to the frame where the mouse movement started. The value
+`dropping' asserts that motion events relate to the frame where the
+mouse cursor is seen when generating the event. If there's no such
+frame, such motion events relate to the frame where the mouse movement
+started. The value `drag-source' is like `dropping', but the
+`posn-window' will be nil in mouse position lists inside mouse
+movement events if there is no frame directly visible underneath the
+mouse pointer. */);
DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist,
doc: /* Alist of system-specific X windows key symbols.
Each element should have the form (N . SYMBOL) where N is the
@@ -12998,6 +13091,12 @@ mark_kboards (void)
mark_object (event->ie.y);
mark_object (event->ie.frame_or_window);
mark_object (event->ie.arg);
+
+ /* This should never be allocated for a single event, but
+ mark it anyway in the situation where the list of devices
+ changed but an event with an old device is still present
+ in the queue. */
+ mark_object (event->ie.device);
}
}
}
diff --git a/src/lisp.h b/src/lisp.h
index 21709b12598..f723876634a 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -622,6 +622,7 @@ extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object);
extern Lisp_Object default_value (Lisp_Object symbol);
extern void defalias (Lisp_Object symbol, Lisp_Object definition);
+extern char *fixnum_to_string (EMACS_INT number, char *buffer, char *end);
/* Defined in emacs.c. */
@@ -2153,6 +2154,7 @@ struct Lisp_Subr
const char *intspec;
Lisp_Object native_intspec;
};
+ Lisp_Object command_modes;
EMACS_INT doc;
#ifdef HAVE_NATIVE_COMP
Lisp_Object native_comp_u;
@@ -3200,6 +3202,76 @@ enum maxargs
'Finsert (1, &text);'. */
#define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__}))
+/* Call function fn on no arguments. */
+INLINE Lisp_Object
+call0 (Lisp_Object fn)
+{
+ return Ffuncall (1, &fn);
+}
+
+/* Call function fn with 1 argument arg1. */
+INLINE Lisp_Object
+call1 (Lisp_Object fn, Lisp_Object arg1)
+{
+ return CALLN (Ffuncall, fn, arg1);
+}
+
+/* Call function fn with 2 arguments arg1, arg2. */
+INLINE Lisp_Object
+call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2);
+}
+
+/* Call function fn with 3 arguments arg1, arg2, arg3. */
+INLINE Lisp_Object
+call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2, arg3);
+}
+
+/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
+INLINE Lisp_Object
+call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+ Lisp_Object arg4)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4);
+}
+
+/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
+INLINE Lisp_Object
+call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+ Lisp_Object arg4, Lisp_Object arg5)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5);
+}
+
+/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
+INLINE Lisp_Object
+call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+ Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6);
+}
+
+/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
+INLINE Lisp_Object
+call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+ Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7);
+}
+
+/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
+ arg6, arg7, arg8. */
+INLINE Lisp_Object
+call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+ Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7,
+ Lisp_Object arg8)
+{
+ return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
+}
+
extern void defvar_lisp (struct Lisp_Objfwd const *, char const *);
extern void defvar_lisp_nopro (struct Lisp_Objfwd const *, char const *);
extern void defvar_bool (struct Lisp_Boolfwd const *, char const *);
@@ -3314,8 +3386,9 @@ union specbinding
} unwind_array;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
- void (*func) (void *);
+ void (*func) (void *); /* Unwind function. */
void *arg;
+ void (*mark) (void *); /* GC mark function (if non-null). */
} unwind_ptr;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
@@ -3908,8 +3981,6 @@ extern void hexbuf_digest (char *, void const *, int);
extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *);
EMACS_UINT hash_string (char const *, ptrdiff_t);
EMACS_UINT sxhash (Lisp_Object);
-Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *);
-Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *);
Lisp_Object hashfn_user_defined (Lisp_Object, struct Lisp_Hash_Table *);
Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
Lisp_Object, bool);
@@ -3925,7 +3996,6 @@ extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t,
extern Lisp_Object merge (Lisp_Object, Lisp_Object, Lisp_Object);
extern Lisp_Object merge_c (Lisp_Object, Lisp_Object, bool (*) (Lisp_Object, Lisp_Object));
extern Lisp_Object do_yes_or_no_p (Lisp_Object);
-extern int string_version_cmp (Lisp_Object, Lisp_Object);
extern Lisp_Object concat2 (Lisp_Object, Lisp_Object);
extern Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern bool equal_no_quit (Lisp_Object, Lisp_Object);
@@ -3939,6 +4009,9 @@ extern Lisp_Object string_to_multibyte (Lisp_Object);
extern Lisp_Object string_make_unibyte (Lisp_Object);
extern void syms_of_fns (void);
+/* Defined in sort.c */
+extern void tim_sort (Lisp_Object, Lisp_Object *, const ptrdiff_t);
+
/* Defined in floatfns.c. */
verify (FLT_RADIX == 2 || FLT_RADIX == 16);
enum { LOG2_FLT_RADIX = FLT_RADIX == 2 ? 1 : 4 };
@@ -4086,7 +4159,7 @@ extern void refill_memory_reserve (void);
#endif
extern void alloc_unexec_pre (void);
extern void alloc_unexec_post (void);
-extern void mark_stack (char const *, char const *);
+extern void mark_c_stack (char const *, char const *);
extern void flush_stack_call_func1 (void (*func) (void *arg), void *arg);
extern void mark_memory (void const *start, void const *end);
@@ -4450,23 +4523,11 @@ extern bool FUNCTIONP (Lisp_Object);
extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector);
extern Lisp_Object eval_sub (Lisp_Object form);
extern Lisp_Object apply1 (Lisp_Object, Lisp_Object);
-extern Lisp_Object call0 (Lisp_Object);
-extern Lisp_Object call1 (Lisp_Object, Lisp_Object);
-extern Lisp_Object call2 (Lisp_Object, Lisp_Object, Lisp_Object);
-extern Lisp_Object call3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
-extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
-extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
-extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
-extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
-extern Lisp_Object call8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object);
extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object);
extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object));
extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
-extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
-extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
-extern Lisp_Object internal_condition_case_5 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
extern Lisp_Object internal_condition_case_n
(Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
@@ -4478,6 +4539,8 @@ extern void specbind (Lisp_Object, Lisp_Object);
extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);
extern void record_unwind_protect_array (Lisp_Object *, ptrdiff_t);
extern void record_unwind_protect_ptr (void (*) (void *), void *);
+extern void record_unwind_protect_ptr_mark (void (*function) (void *),
+ void *arg, void (*mark) (void *));
extern void record_unwind_protect_int (void (*) (int), int);
extern void record_unwind_protect_intmax (void (*) (intmax_t), intmax_t);
extern void record_unwind_protect_void (void (*) (void));
diff --git a/src/lread.c b/src/lread.c
index d7b56c5087e..2538851bac6 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -550,13 +550,21 @@ invalid_syntax_lisp (Lisp_Object s, Lisp_Object readcharfun)
{
if (BUFFERP (readcharfun))
{
+ ptrdiff_t line, column;
+
+ /* Get the line/column in the readcharfun buffer. */
+ {
+ specpdl_ref count = SPECPDL_INDEX ();
+
+ record_unwind_protect_excursion ();
+ set_buffer_internal (XBUFFER (readcharfun));
+ line = count_lines (BEGV_BYTE, PT_BYTE) + 1;
+ column = current_column ();
+ unbind_to (count, Qnil);
+ }
+
xsignal (Qinvalid_read_syntax,
- list3 (s,
- /* We should already be in the readcharfun
- buffer when this error is called, so no need
- to switch to it first. */
- make_fixnum (count_lines (BEGV_BYTE, PT_BYTE) + 1),
- make_fixnum (current_column ())));
+ list3 (s, make_fixnum (line), make_fixnum (column)));
}
else
xsignal1 (Qinvalid_read_syntax, s);
@@ -3480,6 +3488,29 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms)
/* Read the object itself. */
Lisp_Object tem = read0 (readcharfun, locate_syms);
+ if (CONSP (tem))
+ {
+ if (BASE_EQ (tem, placeholder))
+ /* Catch silly games like #1=#1# */
+ invalid_syntax ("nonsensical self-reference",
+ readcharfun);
+
+ /* Optimisation: since the placeholder is already
+ a cons, repurpose it as the actual value.
+ This allows us to skip the substition below,
+ since the placeholder is already referenced
+ inside TEM at the appropriate places. */
+ Fsetcar (placeholder, XCAR (tem));
+ Fsetcdr (placeholder, XCDR (tem));
+
+ struct Lisp_Hash_Table *h2
+ = XHASH_TABLE (read_objects_completed);
+ ptrdiff_t i = hash_lookup (h2, placeholder, &hash);
+ eassert (i < 0);
+ hash_put (h2, placeholder, Qnil, hash);
+ return placeholder;
+ }
+
/* If it can be recursive, remember it for
future substitutions. */
if (! SYMBOLP (tem)
@@ -3494,24 +3525,15 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms)
}
/* Now put it everywhere the placeholder was... */
- if (CONSP (tem))
- {
- Fsetcar (placeholder, XCAR (tem));
- Fsetcdr (placeholder, XCDR (tem));
- return placeholder;
- }
- else
- {
- Flread__substitute_object_in_subtree
- (tem, placeholder, read_objects_completed);
+ Flread__substitute_object_in_subtree
+ (tem, placeholder, read_objects_completed);
- /* ...and #n# will use the real value from now on. */
- i = hash_lookup (h, number, &hash);
- eassert (i >= 0);
- set_hash_value_slot (h, i, tem);
+ /* ...and #n# will use the real value from now on. */
+ i = hash_lookup (h, number, &hash);
+ eassert (i >= 0);
+ set_hash_value_slot (h, i, tem);
- return tem;
- }
+ return tem;
}
/* #n# returns a previously read object. */
diff --git a/src/minibuf.c b/src/minibuf.c
index 49a474dd492..97a6ec69011 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -41,7 +41,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
minibuffer recursions are encountered. */
Lisp_Object Vminibuffer_list;
-Lisp_Object Vcommand_loop_level_list;
+static Lisp_Object Vcommand_loop_level_list;
/* Data to remember during recursive minibuffer invocations. */
diff --git a/src/nsterm.h b/src/nsterm.h
index f0276461231..4cba5c0be8f 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -487,7 +487,7 @@ typedef id instancetype;
#endif
- (int)fullscreenState;
-#ifdef NS_IMPL_COCOA
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
- (void)lockFocus;
- (void)unlockFocus;
#endif
@@ -698,7 +698,7 @@ typedef id instancetype;
+ (CGFloat)scrollerWidth;
@end
-#ifdef NS_IMPL_COCOA
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
@interface EmacsLayer : CALayer
{
NSMutableArray *cache;
diff --git a/src/nsterm.m b/src/nsterm.m
index fd56094c28b..550f29212e9 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -1060,7 +1060,7 @@ ns_update_end (struct frame *f)
block_input ();
[view unlockFocus];
-#if defined (NS_IMPL_GNUSTEP)
+#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400
[[view window] flushWindow];
#endif
@@ -1127,7 +1127,7 @@ ns_unfocus (struct frame *f)
{
EmacsView *view = FRAME_NS_VIEW (f);
[view unlockFocus];
-#if defined (NS_IMPL_GNUSTEP)
+#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400
[[view window] flushWindow];
#endif
}
@@ -2270,6 +2270,7 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
Lisp_Object frame, tail;
struct frame *f = NULL;
struct ns_display_info *dpyinfo;
+ bool return_no_frame_flag = false;
NSTRACE ("ns_mouse_position");
@@ -2313,15 +2314,25 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
#endif
if (!f)
- f = dpyinfo->ns_focus_frame ? dpyinfo->ns_focus_frame : SELECTED_FRAME ();
+ {
+ f = (dpyinfo->ns_focus_frame
+ ? dpyinfo->ns_focus_frame : SELECTED_FRAME ());
+ return_no_frame_flag = EQ (track_mouse, Qdrag_source);
+ }
+
+ if (!FRAME_NS_P (f))
+ f = NULL;
/* While dropping, use the last mouse frame only if there is no
currently focused frame. */
- if (!f
- && EQ (track_mouse, Qdropping)
+ if (!f && (EQ (track_mouse, Qdropping)
+ || EQ (track_mouse, Qdrag_source))
&& dpyinfo->last_mouse_frame
&& FRAME_LIVE_P (dpyinfo->last_mouse_frame))
- f = dpyinfo->last_mouse_frame;
+ {
+ f = dpyinfo->last_mouse_frame;
+ return_no_frame_flag = EQ (track_mouse, Qdrag_source);
+ }
if (f && FRAME_NS_P (f))
{
@@ -2340,7 +2351,7 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
if (y) XSETINT (*y, lrint (view_position.y));
if (time)
*time = dpyinfo->last_mouse_movement_time;
- *fp = f;
+ *fp = return_no_frame_flag ? NULL : f;
}
unblock_input ();
@@ -7197,7 +7208,7 @@ not_in_argv (NSString *arg)
[[EmacsWindow alloc] initWithEmacsFrame:f];
-#ifdef NS_IMPL_COCOA
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
/* These settings mean AppKit will retain the contents of the frame
on resize. Unfortunately it also means the frame will not be
automatically marked for display, but we can do that ourselves in
@@ -7861,8 +7872,8 @@ not_in_argv (NSString *arg)
}
-#ifdef NS_IMPL_COCOA
-- (CALayer *)makeBackingLayer;
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
+- (CALayer *)makeBackingLayer
{
EmacsLayer *l = [[EmacsLayer alloc]
initWithColorSpace:[[[self window] colorSpace] CGColorSpace]];
@@ -7877,19 +7888,12 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsView lockFocus]");
- if ([self wantsLayer])
- {
- CGContextRef context = [(EmacsLayer*)[self layer] getContext];
+ CGContextRef context = [(EmacsLayer*)[self layer] getContext];
- [NSGraphicsContext
+ [NSGraphicsContext
setCurrentContext:[NSGraphicsContext
graphicsContextWithCGContext:context
flipped:YES]];
- }
-#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400
- else
- [super lockFocus];
-#endif
}
@@ -7897,18 +7901,8 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsView unlockFocus]");
- if ([self wantsLayer])
- {
- [NSGraphicsContext setCurrentContext:nil];
- [self setNeedsDisplay:YES];
- }
-#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400
- else
- {
- [super unlockFocus];
- [super flushWindow];
- }
-#endif
+ [NSGraphicsContext setCurrentContext:nil];
+ [self setNeedsDisplay:YES];
}
@@ -7917,19 +7911,16 @@ not_in_argv (NSString *arg)
{
NSTRACE ("EmacsView windowDidChangeBackingProperties:]");
- if ([self wantsLayer])
- {
- NSRect frame = [self frame];
- EmacsLayer *layer = (EmacsLayer *)[self layer];
+ NSRect frame = [self frame];
+ EmacsLayer *layer = (EmacsLayer *)[self layer];
- [layer setContentsScale:[[notification object] backingScaleFactor]];
- [layer setColorSpace:[[[notification object] colorSpace] CGColorSpace]];
+ [layer setContentsScale:[[notification object] backingScaleFactor]];
+ [layer setColorSpace:[[[notification object] colorSpace] CGColorSpace]];
- ns_clear_frame (emacsframe);
- expose_frame (emacsframe, 0, 0, NSWidth (frame), NSHeight (frame));
- }
+ ns_clear_frame (emacsframe);
+ expose_frame (emacsframe, 0, 0, NSWidth (frame), NSHeight (frame));
}
-#endif /* NS_IMPL_COCOA */
+#endif
- (void)copyRect:(NSRect)srcRect to:(NSPoint)dest
@@ -7941,57 +7932,45 @@ not_in_argv (NSString *arg)
NSRect dstRect = NSMakeRect (dest.x, dest.y, NSWidth (srcRect),
NSHeight (srcRect));
-#ifdef NS_IMPL_COCOA
- if ([self wantsLayer])
- {
- double scale = [[self window] backingScaleFactor];
- CGContextRef context = [(EmacsLayer *)[self layer] getContext];
- int bpp = CGBitmapContextGetBitsPerPixel (context) / 8;
- void *pixels = CGBitmapContextGetData (context);
- int rowSize = CGBitmapContextGetBytesPerRow (context);
- int srcRowSize = NSWidth (srcRect) * scale * bpp;
- void *srcPixels = (char *) pixels
- + (int) (NSMinY (srcRect) * scale * rowSize
- + NSMinX (srcRect) * scale * bpp);
- void *dstPixels = (char *) pixels
- + (int) (dest.y * scale * rowSize
- + dest.x * scale * bpp);
-
- if (NSIntersectsRect (srcRect, dstRect)
- && NSMinY (srcRect) < NSMinY (dstRect))
- for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--)
- memmove ((char *) dstPixels + y * rowSize,
- (char *) srcPixels + y * rowSize,
- srcRowSize);
- else
- for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++)
- memmove ((char *) dstPixels + y * rowSize,
- (char *) srcPixels + y * rowSize,
- srcRowSize);
-
- }
-#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
+ double scale = [[self window] backingScaleFactor];
+ CGContextRef context = [(EmacsLayer *)[self layer] getContext];
+ int bpp = CGBitmapContextGetBitsPerPixel (context) / 8;
+ void *pixels = CGBitmapContextGetData (context);
+ int rowSize = CGBitmapContextGetBytesPerRow (context);
+ int srcRowSize = NSWidth (srcRect) * scale * bpp;
+ void *srcPixels = (char *) pixels
+ + (int) (NSMinY (srcRect) * scale * rowSize
+ + NSMinX (srcRect) * scale * bpp);
+ void *dstPixels = (char *) pixels
+ + (int) (dest.y * scale * rowSize
+ + dest.x * scale * bpp);
+
+ if (NSIntersectsRect (srcRect, dstRect)
+ && NSMinY (srcRect) < NSMinY (dstRect))
+ for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--)
+ memmove ((char *) dstPixels + y * rowSize,
+ (char *) srcPixels + y * rowSize,
+ srcRowSize);
else
- {
-#endif
-#endif /* NS_IMPL_COCOA */
+ for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++)
+ memmove ((char *) dstPixels + y * rowSize,
+ (char *) srcPixels + y * rowSize,
+ srcRowSize);
-#if !defined (NS_IMPL_COCOA) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400
- hide_bell(); // Ensure the bell image isn't scrolled.
+#else
+ hide_bell(); // Ensure the bell image isn't scrolled.
- ns_focus (emacsframe, &dstRect, 1);
- [self scrollRect: srcRect
- by: NSMakeSize (dstRect.origin.x - srcRect.origin.x,
- dstRect.origin.y - srcRect.origin.y)];
- ns_unfocus (emacsframe);
-#endif
-#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400
- }
+ ns_focus (emacsframe, &dstRect, 1);
+ [self scrollRect: srcRect
+ by: NSMakeSize (dstRect.origin.x - srcRect.origin.x,
+ dstRect.origin.y - srcRect.origin.y)];
+ ns_unfocus (emacsframe);
#endif
}
-#ifdef NS_IMPL_COCOA
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
/* If the frame has been garbaged but the toolkit wants to draw, for
example when resizing the frame, we end up with a blank screen.
Sometimes this results in an unpleasant flicker, so try to
@@ -8056,6 +8035,37 @@ not_in_argv (NSString *arg)
return YES;
}
+- (BOOL) wantsPeriodicDraggingUpdates
+{
+ return YES;
+}
+
+- (NSDragOperation) draggingUpdated: (id <NSDraggingInfo>) sender
+{
+ struct input_event ie;
+ NSPoint position;
+ int x, y;
+
+ EVENT_INIT (ie);
+ ie.kind = DRAG_N_DROP_EVENT;
+
+ /* Get rid of mouse face. */
+ [self mouseExited: [[self window] currentEvent]];
+
+ position = [self convertPoint: [sender draggingLocation]
+ fromView: nil];
+ x = lrint (position.x);
+ y = lrint (position.y);
+
+ XSETINT (ie.x, x);
+ XSETINT (ie.y, y);
+ XSETFRAME (ie.frame_or_window, emacsframe);
+ ie.arg = Qlambda;
+ ie.modifiers = 0;
+
+ kbd_buffer_store_event (&ie);
+ return NSDragOperationGeneric;
+}
-(BOOL)performDragOperation: (id <NSDraggingInfo>) sender
{
@@ -9435,7 +9445,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
@end /* EmacsScroller */
-#ifdef NS_IMPL_COCOA
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
/* ==========================================================================
diff --git a/src/pdumper.c b/src/pdumper.c
index f14239f863a..24393e03665 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -36,7 +36,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "fingerprint.h"
#include "frame.h"
-#include "getpagesize.h"
#include "intervals.h"
#include "lisp.h"
#include "pdumper.h"
@@ -163,7 +162,7 @@ ptrdiff_t_to_dump_off (ptrdiff_t value)
/* Worst-case allocation granularity on any system that might load
this dump. */
static int
-dump_get_page_size (void)
+dump_get_max_page_size (void)
{
return 64 * 1024;
}
@@ -2854,7 +2853,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v)
static dump_off
dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
{
-#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_F09D8E8E19)
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_A212A8F82A)
# error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h."
#endif
struct Lisp_Subr out;
@@ -2878,11 +2877,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
COLD_OP_NATIVE_SUBR,
make_lisp_ptr ((void *) subr, Lisp_Vectorlike));
dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL);
+ dump_field_lv (ctx, &out, subr, &subr->command_modes, WEIGHT_NORMAL);
}
else
{
dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->command_modes);
}
DUMP_FIELD_COPY (&out, subr, doc);
#ifdef HAVE_NATIVE_COMP
@@ -4209,7 +4210,7 @@ types. */)
eassert (dump_queue_empty_p (&ctx->dump_queue));
dump_off discardable_end = ctx->offset;
- dump_align_output (ctx, dump_get_page_size ());
+ dump_align_output (ctx, dump_get_max_page_size ());
ctx->header.cold_start = ctx->offset;
/* Start the cold section. This section contains bytes that should
@@ -4927,7 +4928,7 @@ dump_mmap_contiguous (struct dump_memory_map *maps, int nr_maps)
return true;
size_t total_size = 0;
- int worst_case_page_size = dump_get_page_size ();
+ int worst_case_page_size = dump_get_max_page_size ();
for (int i = 0; i < nr_maps; ++i)
{
@@ -5615,7 +5616,7 @@ pdumper_load (const char *dump_filename, char *argv0)
err = PDUMPER_LOAD_OOM;
adj_discardable_start = header->discardable_start;
- dump_page_size = dump_get_page_size ();
+ dump_page_size = dump_get_max_page_size ();
/* Snap to next page boundary. */
adj_discardable_start = ROUNDUP (adj_discardable_start, dump_page_size);
eassert (adj_discardable_start % dump_page_size == 0);
diff --git a/src/pgtkfns.c b/src/pgtkfns.c
index 38e60858432..e6ce5e2f443 100644
--- a/src/pgtkfns.c
+++ b/src/pgtkfns.c
@@ -38,13 +38,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "xsettings.h"
#include "atimer.h"
-
-#ifdef HAVE_PGTK
-
-/* Static variables to handle applescript execution. */
-static Lisp_Object as_script, *as_result;
-static int as_status;
-
static ptrdiff_t image_cache_refcount;
static int x_decode_color (struct frame *f, Lisp_Object color_name,
@@ -2219,7 +2212,6 @@ terminate Emacs if we can't open the connection. */)
CHECK_STRING (display);
- nxatoms_of_pgtkselect ();
dpyinfo = pgtk_term_init (display, SSDATA (Vx_resource_name));
if (dpyinfo == 0)
{
@@ -4007,10 +3999,6 @@ be used as the image of the icon representing the frame. */);
defsubr (&Sx_file_dialog);
defsubr (&Sx_select_font);
- as_status = 0;
- as_script = Qnil;
- as_result = 0;
-
monitor_scale_factor_alist = Qnil;
staticpro (&monitor_scale_factor_alist);
@@ -4055,5 +4043,3 @@ be used as the image of the icon representing the frame. */);
DEFSYM (Qreverse_portrait, "reverse-portrait");
DEFSYM (Qreverse_landscape, "reverse-landscape");
}
-
-#endif
diff --git a/src/pgtkselect.c b/src/pgtkselect.c
index 2660ea3ed38..4c87aaa7ea6 100644
--- a/src/pgtkselect.c
+++ b/src/pgtkselect.c
@@ -17,13 +17,15 @@ 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/>. */
-/*
-Originally by Carl Edman
-Updated by Christian Limpach (chris@nice.ch)
-OpenStep/Rhapsody port by Scott Bender (sbender@harmony-ds.com)
-macOS/Aqua port by Christophe de Dinechin (descubes@earthlink.net)
-GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
-*/
+/* FIXME: this file needs a major rewrite to replace the use of GTK's
+ own high-level GtkClipboard API with the GDK selection API:
+
+ https://developer-old.gnome.org/gdk3/stable/gdk3-Selections.html
+
+ That way, most of the code can be shared with X, and non-text
+ targets along with drag-and-drop can be supported. GDK implements
+ selections according to the ICCCM, as on X, but its selection API
+ will work on any supported window system. */
/* This should be the first include, as it may set up #defines affecting
interpretation of even the system includes. */
@@ -151,10 +153,8 @@ selection_type_to_quarks (GdkAtom type, GQuark * quark_data,
*quark_size = quark_clipboard_size;
}
else
- {
- /* fixme: Is it safe to use 'error' here? */
- error ("Unknown selection type.");
- }
+ /* FIXME: Is it safe to use 'error' here? */
+ error ("Unknown selection type.");
}
static void
@@ -492,12 +492,6 @@ frame's display, or the first available display. */)
return Qnil;
}
-
-void
-nxatoms_of_pgtkselect (void)
-{
-}
-
void
syms_of_pgtkselect (void)
{
diff --git a/src/pgtkselect.h b/src/pgtkselect.h
index 0509c83bdec..fd9910b2d18 100644
--- a/src/pgtkselect.h
+++ b/src/pgtkselect.h
@@ -26,8 +26,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <gtk/gtk.h>
extern void pgtk_selection_init (void);
-extern void pgtk_selection_lost (GtkWidget * widget,
- GdkEventSelection * event,
- gpointer user_data);
+extern void pgtk_selection_lost (GtkWidget *, GdkEventSelection *, gpointer);
#endif /* HAVE_PGTK */
diff --git a/src/pgtkterm.c b/src/pgtkterm.c
index e00ed7fa85d..8b60064c421 100644
--- a/src/pgtkterm.c
+++ b/src/pgtkterm.c
@@ -98,15 +98,124 @@ static Time ignore_next_mouse_click_timeout;
static Lisp_Object xg_default_icon_file;
-static void pgtk_delete_display (struct pgtk_display_info *dpyinfo);
-static void pgtk_clear_frame_area (struct frame *f, int x, int y, int width,
- int height);
-static void pgtk_fill_rectangle (struct frame *f, unsigned long color, int x,
- int y, int width, int height,
- bool respect_alpha_background);
-static void pgtk_clip_to_row (struct window *w, struct glyph_row *row,
- enum glyph_row_area area, cairo_t * cr);
-static struct frame *pgtk_any_window_to_frame (GdkWindow *window);
+static void pgtk_delete_display (struct pgtk_display_info *);
+static void pgtk_clear_frame_area (struct frame *, int, int, int, int);
+static void pgtk_fill_rectangle (struct frame *, unsigned long, int, int,
+ int, int, bool);
+static void pgtk_clip_to_row (struct window *, struct glyph_row *,
+ enum glyph_row_area, cairo_t *);
+static struct frame *pgtk_any_window_to_frame (GdkWindow *);
+static void pgtk_regenerate_devices (struct pgtk_display_info *);
+
+static void
+pgtk_device_added_or_removal_cb (GdkSeat *seat, GdkDevice *device,
+ gpointer user_data)
+{
+ pgtk_regenerate_devices (user_data);
+}
+
+static void
+pgtk_seat_added_cb (GdkDisplay *dpy, GdkSeat *seat,
+ gpointer user_data)
+{
+ pgtk_regenerate_devices (user_data);
+
+ g_signal_connect (G_OBJECT (seat), "device-added",
+ G_CALLBACK (pgtk_device_added_or_removal_cb),
+ user_data);
+ g_signal_connect (G_OBJECT (seat), "device-removed",
+ G_CALLBACK (pgtk_device_added_or_removal_cb),
+ user_data);
+}
+
+static void
+pgtk_seat_removed_cb (GdkDisplay *dpy, GdkSeat *seat,
+ gpointer user_data)
+{
+ pgtk_regenerate_devices (user_data);
+
+ g_signal_handlers_disconnect_by_func (G_OBJECT (seat),
+ G_CALLBACK (pgtk_device_added_or_removal_cb),
+ user_data);
+}
+
+static void
+pgtk_enumerate_devices (struct pgtk_display_info *dpyinfo,
+ bool initial_p)
+{
+ struct pgtk_device_t *rec;
+ GList *all_seats, *devices_on_seat, *tem, *t1;
+ GdkSeat *seat;
+ char printbuf[1026]; /* Believe it or not, some device names are
+ actually almost this long. */
+
+ block_input ();
+ all_seats = gdk_display_list_seats (dpyinfo->gdpy);
+
+ for (tem = all_seats; tem; tem = tem->next)
+ {
+ seat = GDK_SEAT (tem->data);
+
+ if (initial_p)
+ {
+ g_signal_connect (G_OBJECT (seat), "device-added",
+ G_CALLBACK (pgtk_device_added_or_removal_cb),
+ dpyinfo);
+ g_signal_connect (G_OBJECT (seat), "device-removed",
+ G_CALLBACK (pgtk_device_added_or_removal_cb),
+ dpyinfo);
+ }
+
+ /* We only want slaves, not master devices. */
+ devices_on_seat = gdk_seat_get_slaves (seat,
+ GDK_SEAT_CAPABILITY_ALL);
+
+ for (t1 = devices_on_seat; t1; t1 = t1->next)
+ {
+ rec = xmalloc (sizeof *rec);
+ rec->seat = g_object_ref (seat);
+ rec->device = GDK_DEVICE (t1->data);
+
+ snprintf (printbuf, 1026, "%u:%s",
+ gdk_device_get_source (rec->device),
+ gdk_device_get_name (rec->device));
+
+ rec->name = build_string (printbuf);
+ rec->next = dpyinfo->devices;
+ dpyinfo->devices = rec;
+ }
+
+ g_list_free (devices_on_seat);
+ }
+
+ g_list_free (all_seats);
+ unblock_input ();
+}
+
+static void
+pgtk_free_devices (struct pgtk_display_info *dpyinfo)
+{
+ struct pgtk_device_t *last, *tem;
+
+ tem = dpyinfo->devices;
+ while (tem)
+ {
+ last = tem;
+ tem = tem->next;
+
+ g_object_unref (last->seat);
+ xfree (last);
+ }
+
+ dpyinfo->devices = NULL;
+}
+
+static void
+pgtk_regenerate_devices (struct pgtk_display_info *dpyinfo)
+{
+ pgtk_free_devices (dpyinfo);
+ pgtk_enumerate_devices (dpyinfo, false);
+}
static void
pgtk_toolkit_position (struct frame *f, int x, int y,
@@ -136,12 +245,31 @@ pgtk_toolkit_position (struct frame *f, int x, int y,
}
}
-/*
- * This is not a flip context in the same sense as gpu rendering
- * scences, it only occurs when a new context was required due to a
- * resize or other fundamental change. This is called when that
- * context's surface has completed drawing
- */
+static Lisp_Object
+pgtk_get_device_for_event (struct pgtk_display_info *dpyinfo,
+ GdkEvent *event)
+{
+ struct pgtk_device_t *tem;
+ GdkDevice *device;
+
+ device = gdk_event_get_source_device (event);
+
+ if (!device)
+ return Qt;
+
+ for (tem = dpyinfo->devices; tem; tem = tem->next)
+ {
+ if (tem->device == device)
+ return tem->name;
+ }
+
+ return Qt;
+}
+
+/* This is not a flip context in the same sense as gpu rendering
+ scenes, it only occurs when a new context was required due to a
+ resize or other fundamental change. This is called when that
+ context's surface has completed drawing. */
static void
flip_cr_context (struct frame *f)
@@ -207,8 +335,11 @@ evq_flush (struct input_event *hold_quit)
void
mark_pgtkterm (void)
{
+ struct pgtk_display_info *dpyinfo;
+ struct pgtk_device_t *device;
struct event_queue_t *evq = &event_q;
int i, n = evq->nr;
+
for (i = 0; i < n; i++)
{
union buffered_input_event *ev = &evq->q[i];
@@ -216,19 +347,22 @@ mark_pgtkterm (void)
mark_object (ev->ie.y);
mark_object (ev->ie.frame_or_window);
mark_object (ev->ie.arg);
+ mark_object (ev->ie.device);
+ }
+
+ for (dpyinfo = x_display_list; dpyinfo;
+ dpyinfo = dpyinfo->next)
+ {
+ for (device = dpyinfo->devices; device;
+ device = device->next)
+ mark_object (device->name);
}
}
char *
get_keysym_name (int keysym)
-/* --------------------------------------------------------------------------
- Called by keyboard.c. Not sure if the return val is important, except
- that it be unique.
- -------------------------------------------------------------------------- */
{
- static char value[16];
- sprintf (value, "%d", keysym);
- return value;
+ return gdk_keyval_name (keysym);
}
void
@@ -531,31 +665,8 @@ pgtk_set_window_size (struct frame *f, bool change_gravity,
gtk_widget_get_size_request (FRAME_GTK_WIDGET (f), &pixelwidth,
&pixelheight);
-#if 0
- if (pixelwise)
- {
- pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
- pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height);
- }
- else
- {
- pixelwidth = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, width);
- pixelheight = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, height);
- }
-#else
pixelwidth = width;
pixelheight = height;
-#endif
-
-#if 0
- frame_size_history_add
- (f, Qx_set_window_size_1, width, height,
- list5 (Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)),
- Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)),
- make_fixnum (f->border_width),
- make_fixnum (FRAME_PGTK_TITLEBAR_HEIGHT (f)),
- make_fixnum (FRAME_TOOLBAR_HEIGHT (f))));
-#endif
for (GtkWidget * w = FRAME_GTK_WIDGET (f); w != NULL;
w = gtk_widget_get_parent (w))
@@ -3329,8 +3440,8 @@ pgtk_frame_up_to_date (struct frame *f)
static void
pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window,
- enum scroll_bar_part *part, Lisp_Object * x,
- Lisp_Object * y, Time * timestamp)
+ enum scroll_bar_part *part, Lisp_Object *x,
+ Lisp_Object *y, Time *timestamp)
{
struct frame *f1;
struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (*fp);
@@ -3339,6 +3450,7 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window,
GdkDevice *device;
GdkModifierType mask;
GdkWindow *win;
+ bool return_frame_flag = false;
block_input ();
@@ -3352,30 +3464,37 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window,
dpyinfo->last_mouse_scroll_bar = NULL;
- if (gui_mouse_grabbed (dpyinfo))
+ if (gui_mouse_grabbed (dpyinfo)
+ && (!EQ (track_mouse, Qdropping)
+ && !EQ (track_mouse, Qdrag_source)))
{
- /* 1.1. use last_mouse_frame as frame where the pointer is on. */
+ /* 1.1. use last_mouse_frame as frame where the pointer is
+ on. */
f1 = dpyinfo->last_mouse_frame;
}
else
{
f1 = *fp;
- /* 1.2. get frame where the pointer is on. */
+ /* 1.2. get frame where the pointer is on. */
win = gtk_widget_get_window (FRAME_GTK_WIDGET (*fp));
seat = gdk_display_get_default_seat (dpyinfo->gdpy);
device = gdk_seat_get_pointer (seat);
- win =
- gdk_window_get_device_position (win, device, &win_x, &win_y, &mask);
+ win = gdk_window_get_device_position (win, device, &win_x,
+ &win_y, &mask);
if (win != NULL)
f1 = pgtk_any_window_to_frame (win);
else
{
- /* crossing display server? */
f1 = SELECTED_FRAME ();
+
+ if (!FRAME_PGTK_P (f1))
+ f1 = dpyinfo->last_mouse_frame;
+
+ return_frame_flag = EQ (track_mouse, Qdrag_source);
}
}
- /* f1 can be a terminal frame. Bug#50322 */
+ /* F1 can be a terminal frame. (Bug#50322) */
if (f1 == NULL || !FRAME_PGTK_P (f1))
{
unblock_input ();
@@ -3399,7 +3518,7 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window,
*bar_window = Qnil;
*part = 0;
- *fp = f1;
+ *fp = !return_frame_flag ? f1 : NULL;
XSETINT (*x, win_x);
XSETINT (*y, win_y);
*timestamp = dpyinfo->last_mouse_movement_time;
@@ -3913,28 +4032,21 @@ xg_scroll_callback (GtkRange * range,
switch (scroll)
{
case GTK_SCROLL_JUMP:
-#if 0
- /* Buttons 1 2 or 3 must be grabbed. */
- if (FRAME_DISPLAY_INFO (f)->grabbed != 0
- && FRAME_DISPLAY_INFO (f)->grabbed < (1 << 4))
-#endif
- {
- if (bar->horizontal)
- {
- part = scroll_bar_horizontal_handle;
- whole = (int) (gtk_adjustment_get_upper (adj) -
- gtk_adjustment_get_page_size (adj));
- portion = min ((int) value, whole);
- bar->dragging = portion;
- }
- else
- {
- part = scroll_bar_handle;
- whole = gtk_adjustment_get_upper (adj) -
- gtk_adjustment_get_page_size (adj);
- portion = min ((int) value, whole);
- bar->dragging = portion;
- }
+ if (bar->horizontal)
+ {
+ part = scroll_bar_horizontal_handle;
+ whole = (int) (gtk_adjustment_get_upper (adj) -
+ gtk_adjustment_get_page_size (adj));
+ portion = min ((int) value, whole);
+ bar->dragging = portion;
+ }
+ else
+ {
+ part = scroll_bar_handle;
+ whole = gtk_adjustment_get_upper (adj) -
+ gtk_adjustment_get_page_size (adj);
+ portion = min ((int) value, whole);
+ bar->dragging = portion;
}
break;
case GTK_SCROLL_STEP_BACKWARD:
@@ -4490,15 +4602,22 @@ pgtk_delete_terminal (struct terminal *terminal)
g_clear_object (&dpyinfo->vertical_scroll_bar_cursor);
g_clear_object (&dpyinfo->horizontal_scroll_bar_cursor);
g_clear_object (&dpyinfo->invisible_cursor);
- if (dpyinfo->last_click_event != NULL) {
- gdk_event_free (dpyinfo->last_click_event);
- dpyinfo->last_click_event = NULL;
- }
+ if (dpyinfo->last_click_event != NULL)
+ {
+ gdk_event_free (dpyinfo->last_click_event);
+ dpyinfo->last_click_event = NULL;
+ }
+ /* Disconnect these handlers before the display closes so
+ useless removal signals don't fire. */
+ g_signal_handlers_disconnect_by_func (G_OBJECT (dpyinfo->gdpy),
+ G_CALLBACK (pgtk_seat_added_cb),
+ dpyinfo);
+ g_signal_handlers_disconnect_by_func (G_OBJECT (dpyinfo->gdpy),
+ G_CALLBACK (pgtk_seat_removed_cb),
+ dpyinfo);
xg_display_close (dpyinfo->gdpy);
- /* Do not close the connection here because it's already closed
- by X(t)CloseDisplay (Bug#18403). */
dpyinfo->gdpy = NULL;
}
@@ -4697,16 +4816,17 @@ pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo)
the appropriate X display info. */
static void
-XTframe_rehighlight (struct frame *frame)
+pgtk_frame_rehighlight_hook (struct frame *frame)
{
pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (frame));
}
-/* Toggle mouse pointer visibility on frame F by using invisible cursor. */
+/* Set whether or not the mouse pointer should be visible on frame
+ F. */
static void
-x_toggle_visible_pointer (struct frame *f, bool invisible)
+pgtk_toggle_invisible_pointer (struct frame *f, bool invisible)
{
Emacs_Cursor cursor;
if (invisible)
@@ -4718,22 +4838,6 @@ x_toggle_visible_pointer (struct frame *f, bool invisible)
f->pointer_invisible = invisible;
}
-static void
-x_setup_pointer_blanking (struct pgtk_display_info *dpyinfo)
-{
- dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer;
- dpyinfo->invisible_cursor =
- gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR);
-}
-
-static void
-XTtoggle_invisible_pointer (struct frame *f, bool invisible)
-{
- block_input ();
- FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible);
- unblock_input ();
-}
-
/* The focus has changed. Update the frames as necessary to reflect
the new situation. Note that we can't change the selected frame
here, because the Lisp code we are interrupting might become confused.
@@ -4790,13 +4894,13 @@ pgtk_create_terminal (struct pgtk_display_info *dpyinfo)
terminal->clear_frame_hook = pgtk_clear_frame;
terminal->ring_bell_hook = pgtk_ring_bell;
- terminal->toggle_invisible_pointer_hook = XTtoggle_invisible_pointer;
+ terminal->toggle_invisible_pointer_hook = pgtk_toggle_invisible_pointer;
terminal->update_begin_hook = pgtk_update_begin;
terminal->update_end_hook = pgtk_update_end;
terminal->read_socket_hook = pgtk_read_socket;
terminal->frame_up_to_date_hook = pgtk_frame_up_to_date;
terminal->mouse_position_hook = pgtk_mouse_position;
- terminal->frame_rehighlight_hook = XTframe_rehighlight;
+ terminal->frame_rehighlight_hook = pgtk_frame_rehighlight_hook;
terminal->buffer_flipping_unblocked_hook = pgtk_buffer_flipping_unblocked_hook;
terminal->frame_raise_lower_hook = pgtk_frame_raise_lower;
terminal->frame_visible_invisible_hook = pgtk_make_frame_visible_invisible;
@@ -4936,6 +5040,8 @@ pgtk_handle_event (GtkWidget *widget, GdkEvent *event, gpointer *data)
make_float (event->touchpad_pinch.angle_delta));
inev.ie.modifiers = pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f),
event->touchpad_pinch.state);
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
evq_enqueue (&inev);
}
@@ -5274,7 +5380,7 @@ pgtk_enqueue_preedit (struct frame *f, Lisp_Object preedit)
}
static gboolean
-key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+key_press_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data)
{
struct coding_system coding;
union buffered_input_event inev;
@@ -5284,8 +5390,6 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
USE_SAFE_ALLOCA;
EVENT_INIT (inev.ie);
- inev.ie.kind = NO_EVENT;
- inev.ie.arg = Qnil;
struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
hlinfo = MOUSE_HL_INFO (f);
@@ -5368,6 +5472,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
{
inev.ie.kind = ASCII_KEYSTROKE_EVENT;
inev.ie.code = keysym;
+
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
goto done;
}
@@ -5379,6 +5486,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
else
inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT;
inev.ie.code = keysym & 0xFFFFFF;
+
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
goto done;
}
@@ -5391,6 +5501,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
? ASCII_KEYSTROKE_EVENT
: MULTIBYTE_CHAR_KEYSTROKE_EVENT);
inev.ie.code = XFIXNAT (c);
+
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
goto done;
}
@@ -5474,6 +5587,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
key. */
inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
inev.ie.code = keysym;
+
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
goto done;
}
@@ -5525,6 +5641,8 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
? ASCII_KEYSTROKE_EVENT
: MULTIBYTE_CHAR_KEYSTROKE_EVENT);
inev.ie.code = ch;
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
evq_enqueue (&inev);
}
@@ -5772,7 +5890,7 @@ x_focus_changed (gboolean is_enter, int state,
}
if (frame->pointer_invisible)
- XTtoggle_invisible_pointer (frame, false);
+ pgtk_toggle_invisible_pointer (frame, false);
}
}
@@ -5906,7 +6024,8 @@ focus_out_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
another motion event, so we can check again the next time it moves. */
static bool
-note_mouse_movement (struct frame *frame, const GdkEventMotion * event)
+note_mouse_movement (struct frame *frame,
+ const GdkEventMotion *event)
{
XRectangle *r;
struct pgtk_display_info *dpyinfo;
@@ -5926,6 +6045,9 @@ note_mouse_movement (struct frame *frame, const GdkEventMotion * event)
dpyinfo->last_mouse_scroll_bar = NULL;
note_mouse_highlight (frame, -1, -1);
dpyinfo->last_mouse_glyph_frame = NULL;
+ frame->last_mouse_device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (frame),
+ (GdkEvent *) event);
return true;
}
@@ -5942,6 +6064,9 @@ note_mouse_movement (struct frame *frame, const GdkEventMotion * event)
/* Remember which glyph we're now on. */
remember_mouse_glyph (frame, event->x, event->y, r);
dpyinfo->last_mouse_glyph_frame = frame;
+ frame->last_mouse_device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (frame),
+ (GdkEvent *) event);
return true;
}
@@ -6057,26 +6182,6 @@ motion_notify_event (GtkWidget * widget, GdkEvent * event,
return TRUE;
}
-/* Mouse clicks and mouse movement. Rah.
-
- Formerly, we used PointerMotionHintMask (in standard_event_mask)
- so that we would have to call XQueryPointer after each MotionNotify
- event to ask for another such event. However, this made mouse tracking
- slow, and there was a bug that made it eventually stop.
-
- Simply asking for MotionNotify all the time seems to work better.
-
- In order to avoid asking for motion events and then throwing most
- of them away or busy-polling the server for mouse positions, we ask
- the server for pointer motion hints. This means that we get only
- one event per group of mouse movements. "Groups" are delimited by
- other kinds of events (focus changes and button clicks, for
- example), or by XQueryPointer calls; when one of these happens, we
- get another MotionNotify event the next time the mouse moves. This
- is at least as efficient as getting motion events when mouse
- tracking is on, and I suspect only negligibly worse when tracking
- is off. */
-
/* Prepare a mouse-event in *RESULT for placement in the input queue.
If the event is a button press, then note that we have grabbed
@@ -6084,7 +6189,8 @@ motion_notify_event (GtkWidget * widget, GdkEvent * event,
static Lisp_Object
construct_mouse_click (struct input_event *result,
- const GdkEventButton * event, struct frame *f)
+ const GdkEventButton *event,
+ struct frame *f)
{
/* Make the event type NO_EVENT; we'll change that when we decide
otherwise. */
@@ -6099,11 +6205,15 @@ construct_mouse_click (struct input_event *result,
XSETINT (result->y, event->y);
XSETFRAME (result->frame_or_window, f);
result->arg = Qnil;
+ result->device = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f),
+ (GdkEvent *) event);
return Qnil;
}
static gboolean
-button_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+button_event (GtkWidget *widget,
+ GdkEvent *event,
+ gpointer *user_data)
{
union buffered_input_event inev;
struct frame *f, *frame;
@@ -6222,7 +6332,7 @@ button_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
}
static gboolean
-scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+scroll_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data)
{
union buffered_input_event inev;
struct frame *f, *frame;
@@ -6254,6 +6364,8 @@ scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
if (gdk_event_is_scroll_stop_event (event))
{
inev.ie.kind = TOUCH_END_EVENT;
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
evq_enqueue (&inev);
return TRUE;
}
@@ -6347,14 +6459,17 @@ scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
}
if (inev.ie.kind != NO_EVENT)
- evq_enqueue (&inev);
+ {
+ inev.ie.device
+ = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event);
+ evq_enqueue (&inev);
+ }
return TRUE;
}
static void
-drag_data_received (GtkWidget * widget, GdkDragContext * context,
- gint x, gint y,
- GtkSelectionData * data,
+drag_data_received (GtkWidget *widget, GdkDragContext *context,
+ gint x, gint y, GtkSelectionData *data,
guint info, guint time, gpointer user_data)
{
struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
@@ -6754,7 +6869,8 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name)
init_sigio (dpyinfo->connection);
}
- x_setup_pointer_blanking (dpyinfo);
+ dpyinfo->invisible_cursor
+ = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR);
xsettings_initialize (dpyinfo);
@@ -6762,6 +6878,12 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name)
pgtk_im_init (dpyinfo);
+ g_signal_connect (G_OBJECT (dpyinfo->gdpy), "seat-added",
+ G_CALLBACK (pgtk_seat_added_cb), dpyinfo);
+ g_signal_connect (G_OBJECT (dpyinfo->gdpy), "seat-removed",
+ G_CALLBACK (pgtk_seat_removed_cb), dpyinfo);
+ pgtk_enumerate_devices (dpyinfo, true);
+
unblock_input ();
return dpyinfo;
@@ -6795,6 +6917,7 @@ pgtk_delete_display (struct pgtk_display_info *dpyinfo)
tail->next = tail->next->next;
}
+ pgtk_free_devices (dpyinfo);
xfree (dpyinfo);
}
@@ -7083,8 +7206,11 @@ pgtk_set_cr_source_with_color (struct frame *f, unsigned long color,
pgtk_query_color (f, &col);
if (!respects_alpha_background)
- cairo_set_source_rgb (FRAME_CR_CONTEXT (f), col.red / 65535.0,
- col.green / 65535.0, col.blue / 65535.0);
+ {
+ cairo_set_source_rgb (FRAME_CR_CONTEXT (f), col.red / 65535.0,
+ col.green / 65535.0, col.blue / 65535.0);
+ cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_OVER);
+ }
else
{
cairo_set_source_rgba (FRAME_CR_CONTEXT (f), col.red / 65535.0,
diff --git a/src/pgtkterm.h b/src/pgtkterm.h
index 4d2285cdb0a..56c5d22e54e 100644
--- a/src/pgtkterm.h
+++ b/src/pgtkterm.h
@@ -40,8 +40,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <cairo-svg.h>
#endif
-/* could use list to store these, but rest of emacs has a big infrastructure
- for managing a table of bitmap "records" */
struct pgtk_bitmap_record
{
void *img;
@@ -51,6 +49,15 @@ struct pgtk_bitmap_record
cairo_pattern_t *pattern;
};
+struct pgtk_device_t
+{
+ GdkSeat *seat;
+ GdkDevice *device;
+
+ Lisp_Object name;
+ struct pgtk_device_t *next;
+};
+
#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b))
#define ARGB_TO_ULONG(a, r, g, b) (((a) << 24) | ((r) << 16) | ((g) << 8) | (b))
@@ -112,8 +119,6 @@ struct scroll_bar
bool horizontal;
};
-
-/* init'd in pgtk_initialize_display_info () */
struct pgtk_display_info
{
/* Chain of all pgtk_display_info structures. */
@@ -208,16 +213,14 @@ struct pgtk_display_info
/* The scroll bar in which the last motion event occurred. */
void *last_mouse_scroll_bar;
- /* The invisible cursor used for pointer blanking.
- Unused if this display supports Xfixes extension. */
+ /* The invisible cursor used for pointer blanking. */
Emacs_Cursor invisible_cursor;
- /* Function used to toggle pointer visibility on this display. */
- void (*toggle_visible_pointer) (struct frame *, bool);
-
/* The GDK cursor for scroll bars and popup menus. */
GdkCursor *xg_cursor;
+ /* List of all devices for all seats on this display. */
+ struct pgtk_device_t *devices;
/* The frame where the mouse was last time we reported a mouse position. */
struct frame *last_mouse_glyph_frame;
@@ -228,7 +231,7 @@ struct pgtk_display_info
/* The last click event. */
GdkEvent *last_click_event;
- /* input method */
+ /* IM context data. */
struct
{
GtkIMContext *context;
@@ -249,10 +252,6 @@ extern struct pgtk_display_info *x_display_list;
struct pgtk_output
{
-#if 0
- void *view;
- void *miniimage;
-#endif
unsigned long foreground_color;
unsigned long background_color;
void *toolbar;
@@ -409,7 +408,7 @@ struct pgtk_output
struct atimer *scale_factor_atimer;
};
-/* this dummy decl needed to support TTYs */
+/* Satisfy term.c. */
struct x_output
{
int unused;
@@ -455,59 +454,8 @@ enum
/* Turning a lisp vector value into a pointer to a struct scroll_bar. */
#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec))
-#define PGTK_FACE_FOREGROUND(f) ((f)->foreground)
-#define PGTK_FACE_BACKGROUND(f) ((f)->background)
#define FRAME_DEFAULT_FACE(f) FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID)
-
-/* Compute pixel height of the frame's titlebar. */
-#define FRAME_PGTK_TITLEBAR_HEIGHT(f) 0
-
-/* Compute pixel size for vertical scroll bars */
-#define PGTK_SCROLL_BAR_WIDTH(f) \
- (FRAME_HAS_VERTICAL_SCROLL_BARS (f) \
- ? rint (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 \
- ? FRAME_CONFIG_SCROLL_BAR_WIDTH (f) \
- : (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f))) \
- : 0)
-
-/* Compute pixel size for horizontal scroll bars */
-#define PGTK_SCROLL_BAR_HEIGHT(f) \
- (FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) \
- ? rint (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 \
- ? FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) \
- : (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f))) \
- : 0)
-
-/* Difference btwn char-column-calculated and actual SB widths.
- This is only a concern for rendering when SB on left. */
-#define PGTK_SCROLL_BAR_ADJUST(w, f) \
- (WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_LEFT (w) ? \
- (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) \
- - PGTK_SCROLL_BAR_WIDTH (f)) : 0)
-
-/* Difference btwn char-line-calculated and actual SB heights.
- This is only a concern for rendering when SB on top. */
-#define PGTK_SCROLL_BAR_ADJUST_HORIZONTALLY(w, f) \
- (WINDOW_HAS_HORIZONTAL_SCROLL_BARS (w) ? \
- (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \
- - PGTK_SCROLL_BAR_HEIGHT (f)) : 0)
-
#define FRAME_MENUBAR_HEIGHT(f) (FRAME_X_OUTPUT (f)->menubar_height)
-
-/* Calculate system coordinates of the left and top of the parent
- window or, if there is no parent window, the screen. */
-#define PGTK_PARENT_WINDOW_LEFT_POS(f) \
- (FRAME_PARENT_FRAME (f) != NULL \
- ? [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.x : 0)
-#define PGTK_PARENT_WINDOW_TOP_POS(f) \
- (FRAME_PARENT_FRAME (f) != NULL \
- ? ([[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.y \
- + [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.size.height \
- - FRAME_PGTK_TITLEBAR_HEIGHT (FRAME_PARENT_FRAME (f))) \
- : [[[PGTKScreen screepgtk] objectAtIndex: 0] frame].size.height)
-
-#define FRAME_PGTK_FONT_TABLE(f) (FRAME_DISPLAY_INFO (f)->font_table)
-
#define FRAME_TOOLBAR_TOP_HEIGHT(f) ((f)->output_data.pgtk->toolbar_top_height)
#define FRAME_TOOLBAR_BOTTOM_HEIGHT(f) \
((f)->output_data.pgtk->toolbar_bottom_height)
@@ -614,9 +562,6 @@ extern void syms_of_pgtkmenu (void);
extern void syms_of_pgtkselect (void);
extern void syms_of_pgtkim (void);
-/* Implemented in pgtkselect. */
-extern void nxatoms_of_pgtkselect (void);
-
/* Initialization and marking implemented in pgtkterm.c */
extern void init_pgtkterm (void);
extern void mark_pgtkterm (void);
diff --git a/src/print.c b/src/print.c
index 704fc278f2d..4a68d15fe02 100644
--- a/src/print.c
+++ b/src/print.c
@@ -2060,8 +2060,10 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
else
{
- int len = sprintf (buf, "%"pI"d", i);
- strout (buf, len, len, printcharfun);
+ char *end = buf + sizeof buf;
+ char *start = fixnum_to_string (i, buf, end);
+ ptrdiff_t len = end - start;
+ strout (start, len, len, printcharfun);
}
}
break;
diff --git a/src/process.c b/src/process.c
index 993e1c56038..08a02ad9423 100644
--- a/src/process.c
+++ b/src/process.c
@@ -6239,7 +6239,6 @@ Otherwise it discards the output. */)
{
Lisp_Object old_read_only;
ptrdiff_t old_begv, old_zv;
- ptrdiff_t old_begv_byte, old_zv_byte;
ptrdiff_t before, before_byte;
ptrdiff_t opoint_byte;
struct buffer *b;
@@ -6250,8 +6249,6 @@ Otherwise it discards the output. */)
old_read_only = BVAR (current_buffer, read_only);
old_begv = BEGV;
old_zv = ZV;
- old_begv_byte = BEGV_BYTE;
- old_zv_byte = ZV_BYTE;
bset_read_only (current_buffer, Qnil);
@@ -6299,15 +6296,9 @@ Otherwise it discards the output. */)
opoint_byte += PT_BYTE - before_byte;
}
if (old_begv > before)
- {
- old_begv += PT - before;
- old_begv_byte += PT_BYTE - before_byte;
- }
+ old_begv += PT - before;
if (old_zv >= before)
- {
- old_zv += PT - before;
- old_zv_byte += PT_BYTE - before_byte;
- }
+ old_zv += PT - before;
/* If the restriction isn't what it should be, set it. */
if (old_begv != BEGV || old_zv != ZV)
@@ -7034,14 +7025,13 @@ abbr_to_signal (char const *name)
return -1;
}
-DEFUN ("signal-process", Fsignal_process, Ssignal_process,
- 2, 2, "sProcess (name or number): \nnSignal code: ",
- doc: /* Send PROCESS the signal with code SIGCODE.
-PROCESS may also be a number specifying the process id of the
-process to signal; in this case, the process need not be a child of
-this Emacs.
-SIGCODE may be an integer, or a symbol whose name is a signal name. */)
- (Lisp_Object process, Lisp_Object sigcode)
+DEFUN ("internal-default-signal-process",
+ Finternal_default_signal_process,
+ Sinternal_default_signal_process, 2, 3, 0,
+ doc: /* Default function to send PROCESS the signal with code SIGCODE.
+It shall be the last element in list `signal-process-functions'.
+See function `signal-process' for more details on usage. */)
+ (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote)
{
pid_t pid;
int signo;
@@ -7091,6 +7081,23 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */)
return make_fixnum (kill (pid, signo));
}
+DEFUN ("signal-process", Fsignal_process, Ssignal_process,
+ 2, 3, "sProcess (name or number): \nnSignal code: ",
+ doc: /* Send PROCESS the signal with code SIGCODE.
+PROCESS may also be a number specifying the process id of the
+process to signal; in this case, the process need not be a child of
+this Emacs.
+If PROCESS is a process object which contains the property
+`remote-pid', or PROCESS is a number and REMOTE is a remote file name,
+PROCESS is interpreted as process on the respective remote host, which
+will be the process to signal.
+SIGCODE may be an integer, or a symbol whose name is a signal name. */)
+ (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote)
+{
+ return CALLN (Frun_hook_with_args_until_success, Qsignal_process_functions,
+ process, sigcode, remote);
+}
+
DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0,
doc: /* Make PROCESS see end-of-file in its input.
EOF comes after any text already sent to it.
@@ -8187,16 +8194,25 @@ DEFUN ("list-system-processes", Flist_system_processes, Slist_system_processes,
0, 0, 0,
doc: /* Return a list of numerical process IDs of all running processes.
If this functionality is unsupported, return nil.
+If `default-directory' is remote, return process IDs of the respective remote host.
See `process-attributes' for getting attributes of a process given its ID. */)
(void)
{
+ Lisp_Object handler
+ = Ffind_file_name_handler (BVAR (current_buffer, directory),
+ Qlist_system_processes);
+ if (!NILP (handler))
+ return call1 (handler, Qlist_system_processes);
+
return list_system_processes ();
}
DEFUN ("process-attributes", Fprocess_attributes,
Sprocess_attributes, 1, 1, 0,
doc: /* Return attributes of the process given by its PID, a number.
+If `default-directory' is remote, PID is regarded as process
+identifier on the respective remote host.
Value is an alist where each element is a cons cell of the form
@@ -8247,6 +8263,12 @@ integer or floating point values.
args -- command line which invoked the process (string). */)
( Lisp_Object pid)
{
+ Lisp_Object handler
+ = Ffind_file_name_handler (BVAR (current_buffer, directory),
+ Qprocess_attributes);
+ if (!NILP (handler))
+ return call2 (handler, Qprocess_attributes, pid);
+
return system_process_attributes (pid);
}
@@ -8422,6 +8444,8 @@ void
syms_of_process (void)
{
DEFSYM (Qmake_process, "make-process");
+ DEFSYM (Qlist_system_processes, "list-system-processes");
+ DEFSYM (Qprocess_attributes, "process-attributes");
#ifdef subprocesses
@@ -8580,6 +8604,13 @@ These functions are called in the order of the list, until one of them
returns non-nil. */);
Vinterrupt_process_functions = list1 (Qinternal_default_interrupt_process);
+ DEFVAR_LISP ("signal-process-functions", Vsignal_process_functions,
+ doc: /* List of functions to be called for `signal-process'.
+The arguments of the functions are the same as for `signal-process'.
+These functions are called in the order of the list, until one of them
+returns non-nil. */);
+ Vsignal_process_functions = list1 (Qinternal_default_signal_process);
+
DEFVAR_LISP ("internal--daemon-sockname", Vinternal__daemon_sockname,
doc: /* Name of external socket passed to Emacs, or nil if none. */);
Vinternal__daemon_sockname = Qnil;
@@ -8600,6 +8631,10 @@ sentinel or a process filter function has an error. */);
"internal-default-interrupt-process");
DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions");
+ DEFSYM (Qinternal_default_signal_process,
+ "internal-default-signal-process");
+ DEFSYM (Qsignal_process_functions, "signal-process-functions");
+
DEFSYM (Qnull, "null");
DEFSYM (Qpipe_process_p, "pipe-process-p");
@@ -8654,6 +8689,7 @@ sentinel or a process filter function has an error. */);
defsubr (&Scontinue_process);
defsubr (&Sprocess_running_child_p);
defsubr (&Sprocess_send_eof);
+ defsubr (&Sinternal_default_signal_process);
defsubr (&Ssignal_process);
defsubr (&Swaiting_for_user_input_p);
defsubr (&Sprocess_type);
diff --git a/src/sort.c b/src/sort.c
new file mode 100644
index 00000000000..c7ccfc23055
--- /dev/null
+++ b/src/sort.c
@@ -0,0 +1,974 @@
+/* Timsort for sequences.
+
+Copyright (C) 2022 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/>. */
+
+/* This is a version of the cpython code implementing the TIMSORT
+ sorting algorithm described in
+ https://github.com/python/cpython/blob/main/Objects/listsort.txt.
+ This algorithm identifies and pushes naturally ordered sublists of
+ the original list, or "runs", onto a stack, and merges them
+ periodically according to a merge strategy called "powersort".
+ State is maintained during the sort in a merge_state structure,
+ which is passed around as an argument to all the subroutines. A
+ "stretch" structure includes a pointer to the run BASE of length
+ LEN along with its POWER (a computed integer used by the powersort
+ merge strategy that depends on this run and the succeeding run.) */
+
+
+#include <config.h>
+#include "lisp.h"
+
+
+/* MAX_MERGE_PENDING is the maximum number of entries in merge_state's
+ pending-stretch stack. For a list with n elements, this needs at most
+ floor(log2(n)) + 1 entries even if we didn't force runs to a
+ minimal length. So the number of bits in a ptrdiff_t is plenty large
+ enough for all cases. */
+
+#define MAX_MERGE_PENDING (sizeof (ptrdiff_t) * 8)
+
+/* Once we get into galloping mode, we stay there as long as both runs
+ win at least GALLOP_WIN_MIN consecutive times. */
+
+#define GALLOP_WIN_MIN 7
+
+/* A small temp array of size MERGESTATE_TEMP_SIZE is used to avoid
+ malloc when merging small lists. */
+
+#define MERGESTATE_TEMP_SIZE 256
+
+struct stretch
+{
+ Lisp_Object *base;
+ ptrdiff_t len;
+ int power;
+};
+
+struct reloc
+{
+ Lisp_Object **src;
+ Lisp_Object **dst;
+ ptrdiff_t *size;
+ int order; /* -1 while in merge_lo; +1 while in merg_hi; 0 otherwise. */
+};
+
+
+typedef struct
+{
+ Lisp_Object *listbase;
+ ptrdiff_t listlen;
+
+ /* PENDING is a stack of N pending stretches yet to be merged.
+ Stretch #i starts at address base[i] and extends for len[i]
+ elements. */
+
+ int n;
+ struct stretch pending[MAX_MERGE_PENDING];
+
+ /* The variable MIN_GALLOP, initialized to GALLOP_WIN_MIN, controls
+ when we get *into* galloping mode. merge_lo and merge_hi tend to
+ nudge it higher for random data, and lower for highly structured
+ data. */
+
+ ptrdiff_t min_gallop;
+
+ /* 'A' is temporary storage, able to hold ALLOCED elements, to help
+ with merges. 'A' initially points to TEMPARRAY, and subsequently
+ to newly allocated memory if needed. */
+
+ Lisp_Object *a;
+ ptrdiff_t alloced;
+ specpdl_ref count;
+ Lisp_Object temparray[MERGESTATE_TEMP_SIZE];
+
+ /* If an exception is thrown while merging we might have to relocate
+ some list elements from temporary storage back into the list.
+ RELOC keeps track of the information needed to do this. */
+
+ struct reloc reloc;
+
+ /* PREDICATE is the lisp comparison predicate for the sort. */
+
+ Lisp_Object predicate;
+} merge_state;
+
+
+/* Return true iff (PREDICATE A B) is non-nil. */
+
+static inline bool
+inorder (const Lisp_Object predicate, const Lisp_Object a, const Lisp_Object b)
+{
+ return !NILP (call2 (predicate, a, b));
+}
+
+
+/* Sort the list starting at LO and ending at HI using a stable binary
+ insertion sort algorithm. On entry the sublist [LO, START) (with
+ START between LO and HIGH) is known to be sorted (pass START == LO
+ if you are unsure). Even in case of error, the output will be some
+ permutation of the input (nothing is lost or duplicated). */
+
+static void
+binarysort (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
+ Lisp_Object *start)
+{
+ Lisp_Object pred = ms->predicate;
+
+ eassume (lo <= start && start <= hi);
+ if (lo == start)
+ ++start;
+ for (; start < hi; ++start)
+ {
+ Lisp_Object *l = lo;
+ Lisp_Object *r = start;
+ Lisp_Object pivot = *r;
+
+ eassume (l < r);
+ do {
+ Lisp_Object *p = l + ((r - l) >> 1);
+ if (inorder (pred, pivot, *p))
+ r = p;
+ else
+ l = p + 1;
+ } while (l < r);
+ eassume (l == r);
+ for (Lisp_Object *p = start; p > l; --p)
+ p[0] = p[-1];
+ *l = pivot;
+ }
+}
+
+
+/* Find and return the length of the "run" (the longest
+ non-decreasing sequence or the longest strictly decreasing
+ sequence, with the Boolean *DESCENDING set to 0 in the former
+ case, or to 1 in the latter) beginning at LO, in the slice [LO,
+ HI) with LO < HI. The strictness of the definition of
+ "descending" ensures there are no equal elements to get out of
+ order so the caller can safely reverse a descending sequence
+ without violating stability. */
+
+static ptrdiff_t
+count_run (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
+ bool *descending)
+{
+ Lisp_Object pred = ms->predicate;
+
+ eassume (lo < hi);
+ *descending = 0;
+ ++lo;
+ ptrdiff_t n = 1;
+ if (lo == hi)
+ return n;
+
+ n = 2;
+ if (inorder (pred, lo[0], lo[-1]))
+ {
+ *descending = 1;
+ for (lo = lo + 1; lo < hi; ++lo, ++n)
+ {
+ if (!inorder (pred, lo[0], lo[-1]))
+ break;
+ }
+ }
+ else
+ {
+ for (lo = lo + 1; lo < hi; ++lo, ++n)
+ {
+ if (inorder (pred, lo[0], lo[-1]))
+ break;
+ }
+ }
+
+ return n;
+}
+
+
+/* Locate and return the proper insertion position of KEY in a sorted
+ vector: if the vector contains an element equal to KEY, return the
+ position immediately to the left of the leftmost equal element.
+ [GALLOP_RIGHT does the same except it returns the position to the
+ right of the rightmost equal element (if any).]
+
+ 'A' is a sorted vector of N elements. N must be > 0.
+
+ Elements preceding HINT, a non-negative index less than N, are
+ skipped. The closer HINT is to the final result, the faster this
+ runs.
+
+ The return value is the int k in [0, N] such that
+
+ A[k-1] < KEY <= a[k]
+
+ pretending that *(A-1) precedes all values and *(A+N) succeeds all
+ values. In other words, the first k elements of A should precede
+ KEY, and the last N-k should follow KEY. */
+
+static ptrdiff_t
+gallop_left (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
+ const ptrdiff_t n, const ptrdiff_t hint)
+{
+ Lisp_Object pred = ms->predicate;
+
+ eassume (a && n > 0 && hint >= 0 && hint < n);
+
+ a += hint;
+ ptrdiff_t lastofs = 0;
+ ptrdiff_t ofs = 1;
+ if (inorder (pred, *a, key))
+ {
+ /* When a[hint] < key, gallop right until
+ a[hint + lastofs] < key <= a[hint + ofs]. */
+ const ptrdiff_t maxofs = n - hint; /* This is one after the end of a. */
+ while (ofs < maxofs)
+ {
+ if (inorder (pred, a[ofs], key))
+ {
+ lastofs = ofs;
+ eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
+ ofs = (ofs << 1) + 1;
+ }
+ else
+ break; /* Here key <= a[hint+ofs]. */
+ }
+ if (ofs > maxofs)
+ ofs = maxofs;
+ /* Translate back to offsets relative to &a[0]. */
+ lastofs += hint;
+ ofs += hint;
+ }
+ else
+ {
+ /* When key <= a[hint], gallop left, until
+ a[hint - ofs] < key <= a[hint - lastofs]. */
+ const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */
+ while (ofs < maxofs)
+ {
+ if (inorder (pred, a[-ofs], key))
+ break;
+ /* Here key <= a[hint - ofs]. */
+ lastofs = ofs;
+ eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
+ ofs = (ofs << 1) + 1;
+ }
+ if (ofs > maxofs)
+ ofs = maxofs;
+ /* Translate back to use positive offsets relative to &a[0]. */
+ ptrdiff_t k = lastofs;
+ lastofs = hint - ofs;
+ ofs = hint - k;
+ }
+ a -= hint;
+
+ eassume (-1 <= lastofs && lastofs < ofs && ofs <= n);
+ /* Now a[lastofs] < key <= a[ofs], so key belongs somewhere to the
+ right of lastofs but no farther right than ofs. Do a binary
+ search, with invariant a[lastofs-1] < key <= a[ofs]. */
+ ++lastofs;
+ while (lastofs < ofs)
+ {
+ ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1);
+
+ if (inorder (pred, a[m], key))
+ lastofs = m + 1; /* Here a[m] < key. */
+ else
+ ofs = m; /* Here key <= a[m]. */
+ }
+ eassume (lastofs == ofs); /* Then a[ofs-1] < key <= a[ofs]. */
+ return ofs;
+}
+
+
+/* Locate and return the proper position of KEY in a sorted vector
+ exactly like GALLOP_LEFT, except that if KEY already exists in
+ A[0:N] find the position immediately to the right of the rightmost
+ equal value.
+
+ The return value is the int k in [0, N] such that
+
+ A[k-1] <= KEY < A[k]. */
+
+static ptrdiff_t
+gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
+ const ptrdiff_t n, const ptrdiff_t hint)
+{
+ Lisp_Object pred = ms->predicate;
+
+ eassume (a && n > 0 && hint >= 0 && hint < n);
+
+ a += hint;
+ ptrdiff_t lastofs = 0;
+ ptrdiff_t ofs = 1;
+ if (inorder (pred, key, *a))
+ {
+ /* When key < a[hint], gallop left until
+ a[hint - ofs] <= key < a[hint - lastofs]. */
+ const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */
+ while (ofs < maxofs)
+ {
+ if (inorder (pred, key, a[-ofs]))
+ {
+ lastofs = ofs;
+ eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
+ ofs = (ofs << 1) + 1;
+ }
+ else /* Here a[hint - ofs] <= key. */
+ break;
+ }
+ if (ofs > maxofs)
+ ofs = maxofs;
+ /* Translate back to use positive offsets relative to &a[0]. */
+ ptrdiff_t k = lastofs;
+ lastofs = hint - ofs;
+ ofs = hint - k;
+ }
+ else
+ {
+ /* When a[hint] <= key, gallop right, until
+ a[hint + lastofs] <= key < a[hint + ofs]. */
+ const ptrdiff_t maxofs = n - hint; /* Here &a[n-1] is highest. */
+ while (ofs < maxofs)
+ {
+ if (inorder (pred, key, a[ofs]))
+ break;
+ /* Here a[hint + ofs] <= key. */
+ lastofs = ofs;
+ eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
+ ofs = (ofs << 1) + 1;
+ }
+ if (ofs > maxofs)
+ ofs = maxofs;
+ /* Translate back to use offsets relative to &a[0]. */
+ lastofs += hint;
+ ofs += hint;
+ }
+ a -= hint;
+
+ eassume (-1 <= lastofs && lastofs < ofs && ofs <= n);
+ /* Now a[lastofs] <= key < a[ofs], so key belongs somewhere to the
+ right of lastofs but no farther right than ofs. Do a binary
+ search, with invariant a[lastofs-1] <= key < a[ofs]. */
+ ++lastofs;
+ while (lastofs < ofs)
+ {
+ ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1);
+
+ if (inorder (pred, key, a[m]))
+ ofs = m; /* Here key < a[m]. */
+ else
+ lastofs = m + 1; /* Here a[m] <= key. */
+ }
+ eassume (lastofs == ofs); /* Now a[ofs-1] <= key < a[ofs]. */
+ return ofs;
+}
+
+
+static void
+merge_init (merge_state *ms, const ptrdiff_t list_size, Lisp_Object *lo,
+ const Lisp_Object predicate)
+{
+ eassume (ms != NULL);
+
+ ms->a = ms->temparray;
+ ms->alloced = MERGESTATE_TEMP_SIZE;
+
+ ms->n = 0;
+ ms->min_gallop = GALLOP_WIN_MIN;
+ ms->listlen = list_size;
+ ms->listbase = lo;
+ ms->predicate = predicate;
+ ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
+}
+
+
+/* The dynamically allocated memory may hold lisp objects during
+ merging. MERGE_MARKMEM marks them so they aren't reaped during
+ GC. */
+
+static void
+merge_markmem (void *arg)
+{
+ merge_state *ms = arg;
+ eassume (ms != NULL);
+
+ if (ms->reloc.size != NULL && *ms->reloc.size > 0)
+ {
+ eassume (ms->reloc.src != NULL);
+ mark_objects (*ms->reloc.src, *ms->reloc.size);
+ }
+}
+
+
+/* Free all temp storage. If an exception occurs while merging,
+ relocate any lisp elements in temp storage back to the original
+ array. */
+
+static void
+cleanup_mem (void *arg)
+{
+ merge_state *ms = arg;
+ eassume (ms != NULL);
+
+ /* If we have an exception while merging, some of the list elements
+ might only live in temp storage; we copy everything remaining in
+ the temp storage back into the original list. This ensures that
+ the original list has all of the original elements, although
+ their order is unpredictable. */
+
+ if (ms->reloc.order != 0 && *ms->reloc.size > 0)
+ {
+ eassume (*ms->reloc.src != NULL && *ms->reloc.dst != NULL);
+ ptrdiff_t n = *ms->reloc.size;
+ ptrdiff_t shift = ms->reloc.order == -1 ? 0 : n - 1;
+ memcpy (*ms->reloc.dst - shift, *ms->reloc.src, n * word_size);
+ }
+
+ /* Free any remaining temp storage. */
+ xfree (ms->a);
+}
+
+
+/* Allocate enough temp memory for NEED array slots. Any previously
+ allocated memory is first freed, and a cleanup routine is
+ registered to free memory at the very end of the sort, or on
+ exception. */
+
+static void
+merge_getmem (merge_state *ms, const ptrdiff_t need)
+{
+ eassume (ms != NULL);
+
+ if (ms->a == ms->temparray)
+ {
+ /* We only get here if alloc is needed and this is the first
+ time, so we set up the unwind protection. */
+ specpdl_ref count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr_mark (cleanup_mem, ms, merge_markmem);
+ ms->count = count;
+ }
+ else
+ {
+ /* We have previously alloced storage. Since we don't care
+ what's in the block we don't use realloc which would waste
+ cycles copying the old data. We just free and alloc
+ again. */
+ xfree (ms->a);
+ }
+ ms->a = xmalloc (need * word_size);
+ ms->alloced = need;
+}
+
+
+static inline void
+needmem (merge_state *ms, ptrdiff_t na)
+{
+ if (na > ms->alloced)
+ merge_getmem (ms, na);
+}
+
+
+/* Stably merge (in-place) the NA elements starting at SSA with the NB
+ elements starting at SSB = SSA + NA. NA and NB must be positive.
+ Require that SSA[NA-1] belongs at the end of the merge, and NA <=
+ NB. */
+
+static void
+merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
+ ptrdiff_t nb)
+{
+ Lisp_Object pred = ms->predicate;
+
+ eassume (ms && ssa && ssb && na > 0 && nb > 0);
+ eassume (ssa + na == ssb);
+ needmem (ms, na);
+ memcpy (ms->a, ssa, na * word_size);
+ Lisp_Object *dest = ssa;
+ ssa = ms->a;
+
+ ms->reloc = (struct reloc){&ssa, &dest, &na, -1};
+
+ *dest++ = *ssb++;
+ --nb;
+ if (nb == 0)
+ goto Succeed;
+ if (na == 1)
+ goto CopyB;
+
+ ptrdiff_t min_gallop = ms->min_gallop;
+ for (;;)
+ {
+ ptrdiff_t acount = 0; /* The # of consecutive times A won. */
+
+ ptrdiff_t bcount = 0; /* The # of consecutive times B won. */
+
+ for (;;)
+ {
+ eassume (na > 1 && nb > 0);
+ if (inorder (pred, *ssb, *ssa))
+ {
+ *dest++ = *ssb++ ;
+ ++bcount;
+ acount = 0;
+ --nb;
+ if (nb == 0)
+ goto Succeed;
+ if (bcount >= min_gallop)
+ break;
+ }
+ else
+ {
+ *dest++ = *ssa++;
+ ++acount;
+ bcount = 0;
+ --na;
+ if (na == 1)
+ goto CopyB;
+ if (acount >= min_gallop)
+ break;
+ }
+ }
+
+ /* One run is winning so consistently that galloping may be a
+ huge speedup. We try that, and continue galloping until (if
+ ever) neither run appears to be winning consistently
+ anymore. */
+ ++min_gallop;
+ do {
+ eassume (na > 1 && nb > 0);
+ min_gallop -= min_gallop > 1;
+ ms->min_gallop = min_gallop;
+ ptrdiff_t k = gallop_right (ms, ssb[0], ssa, na, 0);
+ acount = k;
+ if (k)
+ {
+ memcpy (dest, ssa, k * word_size);
+ dest += k;
+ ssa += k;
+ na -= k;
+ if (na == 1)
+ goto CopyB;
+ /* While na==0 is impossible for a consistent comparison
+ function, we shouldn't assume that it is. */
+ if (na == 0)
+ goto Succeed;
+ }
+ *dest++ = *ssb++ ;
+ --nb;
+ if (nb == 0)
+ goto Succeed;
+
+ k = gallop_left (ms, ssa[0], ssb, nb, 0);
+ bcount = k;
+ if (k)
+ {
+ memmove (dest, ssb, k * word_size);
+ dest += k;
+ ssb += k;
+ nb -= k;
+ if (nb == 0)
+ goto Succeed;
+ }
+ *dest++ = *ssa++;
+ --na;
+ if (na == 1)
+ goto CopyB;
+ } while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN);
+ ++min_gallop; /* Apply a penalty for leaving galloping mode. */
+ ms->min_gallop = min_gallop;
+ }
+ Succeed:
+ ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
+
+ if (na)
+ memcpy (dest, ssa, na * word_size);
+ return;
+ CopyB:
+ eassume (na == 1 && nb > 0);
+ ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
+
+ /* The last element of ssa belongs at the end of the merge. */
+ memmove (dest, ssb, nb * word_size);
+ dest[nb] = ssa[0];
+}
+
+
+/* Stably merge (in-place) the NA elements starting at SSA with the NB
+ elements starting at SSB = SSA + NA. NA and NB must be positive.
+ Require that SSA[NA-1] belongs at the end of the merge, and NA >=
+ NB. */
+
+static void
+merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
+ Lisp_Object *ssb, ptrdiff_t nb)
+{
+ Lisp_Object pred = ms->predicate;
+
+ eassume (ms && ssa && ssb && na > 0 && nb > 0);
+ eassume (ssa + na == ssb);
+ needmem (ms, nb);
+ Lisp_Object *dest = ssb;
+ dest += nb - 1;
+ memcpy(ms->a, ssb, nb * word_size);
+ Lisp_Object *basea = ssa;
+ Lisp_Object *baseb = ms->a;
+ ssb = ms->a + nb - 1;
+ ssa += na - 1;
+
+ ms->reloc = (struct reloc){&baseb, &dest, &nb, 1};
+
+ *dest-- = *ssa--;
+ --na;
+ if (na == 0)
+ goto Succeed;
+ if (nb == 1)
+ goto CopyA;
+
+ ptrdiff_t min_gallop = ms->min_gallop;
+ for (;;) {
+ ptrdiff_t acount = 0; /* The # of consecutive times A won. */
+ ptrdiff_t bcount = 0; /* The # of consecutive times B won. */
+
+ for (;;) {
+ eassume (na > 0 && nb > 1);
+ if (inorder (pred, *ssb, *ssa))
+ {
+ *dest-- = *ssa--;
+ ++acount;
+ bcount = 0;
+ --na;
+ if (na == 0)
+ goto Succeed;
+ if (acount >= min_gallop)
+ break;
+ }
+ else
+ {
+ *dest-- = *ssb--;
+ ++bcount;
+ acount = 0;
+ --nb;
+ if (nb == 1)
+ goto CopyA;
+ if (bcount >= min_gallop)
+ break;
+ }
+ }
+
+ /* One run is winning so consistently that galloping may be a huge
+ speedup. Try that, and continue galloping until (if ever)
+ neither run appears to be winning consistently anymore. */
+ ++min_gallop;
+ do {
+ eassume (na > 0 && nb > 1);
+ min_gallop -= min_gallop > 1;
+ ms->min_gallop = min_gallop;
+ ptrdiff_t k = gallop_right (ms, ssb[0], basea, na, na - 1);
+ k = na - k;
+ acount = k;
+ if (k)
+ {
+ dest += -k;
+ ssa += -k;
+ memmove(dest + 1, ssa + 1, k * word_size);
+ na -= k;
+ if (na == 0)
+ goto Succeed;
+ }
+ *dest-- = *ssb--;
+ --nb;
+ if (nb == 1)
+ goto CopyA;
+
+ k = gallop_left (ms, ssa[0], baseb, nb, nb - 1);
+ k = nb - k;
+ bcount = k;
+ if (k)
+ {
+ dest += -k;
+ ssb += -k;
+ memcpy(dest + 1, ssb + 1, k * word_size);
+ nb -= k;
+ if (nb == 1)
+ goto CopyA;
+ /* While nb==0 is impossible for a consistent comparison
+ function we shouldn't assume that it is. */
+ if (nb == 0)
+ goto Succeed;
+ }
+ *dest-- = *ssa--;
+ --na;
+ if (na == 0)
+ goto Succeed;
+ } while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN);
+ ++min_gallop; /* Apply a penalty for leaving galloping mode. */
+ ms->min_gallop = min_gallop;
+ }
+ Succeed:
+ ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
+ if (nb)
+ memcpy (dest - nb + 1, baseb, nb * word_size);
+ return;
+ CopyA:
+ eassume (nb == 1 && na > 0);
+ ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
+ /* The first element of ssb belongs at the front of the merge. */
+ memmove (dest + 1 - na, ssa + 1 - na, na * word_size);
+ dest += -na;
+ ssa += -na;
+ dest[0] = ssb[0];
+}
+
+
+/* Merge the two runs at stack indices I and I+1. */
+
+static void
+merge_at (merge_state *ms, const ptrdiff_t i)
+{
+ eassume (ms != NULL);
+ eassume (ms->n >= 2);
+ eassume (i >= 0);
+ eassume (i == ms->n - 2 || i == ms->n - 3);
+
+ Lisp_Object *ssa = ms->pending[i].base;
+ ptrdiff_t na = ms->pending[i].len;
+ Lisp_Object *ssb = ms->pending[i + 1].base;
+ ptrdiff_t nb = ms->pending[i + 1].len;
+ eassume (na > 0 && nb > 0);
+ eassume (ssa + na == ssb);
+
+ /* Record the length of the combined runs. The current run i+1 goes
+ away after the merge. If i is the 3rd-last run now, slide the
+ last run (which isn't involved in this merge) over to i+1. */
+ ms->pending[i].len = na + nb;
+ if (i == ms->n - 3)
+ ms->pending[i + 1] = ms->pending[i + 2];
+ --ms->n;
+
+ /* Where does b start in a? Elements in a before that can be
+ ignored (they are already in place). */
+ ptrdiff_t k = gallop_right (ms, *ssb, ssa, na, 0);
+ eassume (k >= 0);
+ ssa += k;
+ na -= k;
+ if (na == 0)
+ return;
+
+ /* Where does a end in b? Elements in b after that can be ignored
+ (they are already in place). */
+ nb = gallop_left (ms, ssa[na - 1], ssb, nb, nb - 1);
+ if (nb == 0)
+ return;
+ eassume (nb > 0);
+ /* Merge what remains of the runs using a temp array with size
+ min(na, nb) elements. */
+ if (na <= nb)
+ merge_lo (ms, ssa, na, ssb, nb);
+ else
+ merge_hi (ms, ssa, na, ssb, nb);
+}
+
+
+/* Compute the "power" of the first of two adjacent runs begining at
+ index S1, with the first having length N1 and the second (starting
+ at index S1+N1) having length N2. The run has total length N. */
+
+static int
+powerloop (const ptrdiff_t s1, const ptrdiff_t n1, const ptrdiff_t n2,
+ const ptrdiff_t n)
+{
+ eassume (s1 >= 0);
+ eassume (n1 > 0 && n2 > 0);
+ eassume (s1 + n1 + n2 <= n);
+ /* The midpoints a and b are
+ a = s1 + n1/2
+ b = s1 + n1 + n2/2 = a + (n1 + n2)/2
+
+ These may not be integers because of the "/2", so we work with
+ 2*a and 2*b instead. It makes no difference to the outcome,
+ since the bits in the expansion of (2*i)/n are merely shifted one
+ position from those of i/n. */
+ ptrdiff_t a = 2 * s1 + n1;
+ ptrdiff_t b = a + n1 + n2;
+ int result = 0;
+ /* Emulate a/n and b/n one bit a time, until their bits differ. */
+ for (;;)
+ {
+ ++result;
+ if (a >= n)
+ { /* Both quotient bits are now 1. */
+ eassume (b >= a);
+ a -= n;
+ b -= n;
+ }
+ else if (b >= n)
+ { /* a/n bit is 0 and b/n bit is 1. */
+ break;
+ } /* Otherwise both quotient bits are 0. */
+ eassume (a < b && b < n);
+ a <<= 1;
+ b <<= 1;
+ }
+ return result;
+}
+
+
+/* Update the state upon identifying a run of length N2. If there's
+ already a stretch on the stack, apply the "powersort" merge
+ strategy: compute the topmost stretch's "power" (depth in a
+ conceptual binary merge tree) and merge adjacent runs on the stack
+ with greater power. */
+
+static void
+found_new_run (merge_state *ms, const ptrdiff_t n2)
+{
+ eassume (ms != NULL);
+ if (ms->n)
+ {
+ eassume (ms->n > 0);
+ struct stretch *p = ms->pending;
+ ptrdiff_t s1 = p[ms->n - 1].base - ms->listbase;
+ ptrdiff_t n1 = p[ms->n - 1].len;
+ int power = powerloop (s1, n1, n2, ms->listlen);
+ while (ms->n > 1 && p[ms->n - 2].power > power)
+ {
+ merge_at (ms, ms->n - 2);
+ }
+ eassume (ms->n < 2 || p[ms->n - 2].power < power);
+ p[ms->n - 1].power = power;
+ }
+}
+
+
+/* Unconditionally merge all stretches on the stack until only one
+ remains. */
+
+static void
+merge_force_collapse (merge_state *ms)
+{
+ struct stretch *p = ms->pending;
+
+ eassume (ms != NULL);
+ while (ms->n > 1)
+ {
+ ptrdiff_t n = ms->n - 2;
+ if (n > 0 && p[n - 1].len < p[n + 1].len)
+ --n;
+ merge_at (ms, n);
+ }
+}
+
+
+/* Compute a good value for the minimum run length; natural runs
+ shorter than this are boosted artificially via binary insertion.
+
+ If N < 64, return N (it's too small to bother with fancy stuff).
+ Otherwise if N is an exact power of 2, return 32. Finally, return
+ an int k, 32 <= k <= 64, such that N/k is close to, but strictly
+ less than, an exact power of 2. */
+
+static ptrdiff_t
+merge_compute_minrun (ptrdiff_t n)
+{
+ ptrdiff_t r = 0; /* r will become 1 if any non-zero bits are
+ shifted off. */
+
+ eassume (n >= 0);
+ while (n >= 64)
+ {
+ r |= n & 1;
+ n >>= 1;
+ }
+ return n + r;
+}
+
+
+static void
+reverse_vector (Lisp_Object *s, const ptrdiff_t n)
+{
+ for (ptrdiff_t i = 0; i < n >> 1; i++)
+ {
+ Lisp_Object tem = s[i];
+ s[i] = s[n - i - 1];
+ s[n - i - 1] = tem;
+ }
+}
+
+/* Sort the array SEQ with LENGTH elements in the order determined by
+ PREDICATE. */
+
+void
+tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length)
+{
+ if (SYMBOLP (predicate))
+ {
+ /* Attempt to resolve the function as far as possible ahead of time,
+ to avoid having to do it for each call. */
+ Lisp_Object fun = XSYMBOL (predicate)->u.s.function;
+ if (SYMBOLP (fun))
+ /* Function was an alias; use slow-path resolution. */
+ fun = indirect_function (fun);
+ /* Don't resolve to an autoload spec; that would be very slow. */
+ if (!NILP (fun) && !(CONSP (fun) && EQ (XCAR (fun), Qautoload)))
+ predicate = fun;
+ }
+
+ merge_state ms;
+ Lisp_Object *lo = seq;
+
+ merge_init (&ms, length, lo, predicate);
+
+ /* March over the array once, left to right, finding natural runs,
+ and extending short natural runs to minrun elements. */
+ const ptrdiff_t minrun = merge_compute_minrun (length);
+ ptrdiff_t nremaining = length;
+ do {
+ bool descending;
+
+ /* Identify the next run. */
+ ptrdiff_t n = count_run (&ms, lo, lo + nremaining, &descending);
+ if (descending)
+ reverse_vector (lo, n);
+ /* If the run is short, extend it to min(minrun, nremaining). */
+ if (n < minrun)
+ {
+ const ptrdiff_t force = nremaining <= minrun ?
+ nremaining : minrun;
+ binarysort (&ms, lo, lo + force, lo + n);
+ n = force;
+ }
+ eassume (ms.n == 0 || ms.pending[ms.n - 1].base +
+ ms.pending[ms.n - 1].len == lo);
+ found_new_run (&ms, n);
+ /* Push the new run on to the stack. */
+ eassume (ms.n < MAX_MERGE_PENDING);
+ ms.pending[ms.n].base = lo;
+ ms.pending[ms.n].len = n;
+ ++ms.n;
+ /* Advance to find the next run. */
+ lo += n;
+ nremaining -= n;
+ } while (nremaining);
+
+ merge_force_collapse (&ms);
+ eassume (ms.n == 1);
+ eassume (ms.pending[0].len == length);
+ lo = ms.pending[0].base;
+
+ if (ms.a != ms.temparray)
+ unbind_to (ms.count, Qnil);
+}
diff --git a/src/sqlite.c b/src/sqlite.c
index 649cb382948..1ca86699318 100644
--- a/src/sqlite.c
+++ b/src/sqlite.c
@@ -1,4 +1,5 @@
-/*
+/* Support for accessing SQLite databases.
+
Copyright (C) 2021-2022 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -19,8 +20,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
This file is based on the emacs-sqlite3 package written by Syohei
YOSHIDA <syohex@gmail.com>, which can be found at:
- https://github.com/syohex/emacs-sqlite3
-*/
+ https://github.com/syohex/emacs-sqlite3 */
#include <config.h>
#include "lisp.h"
diff --git a/src/syntax.c b/src/syntax.c
index 13c36fdf3cd..f9022d18d26 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -1074,7 +1074,7 @@ unsigned char const syntax_spec_code[0400] =
/* Indexed by syntax code, give the letter that describes it. */
-char const syntax_code_spec[16] =
+static char const syntax_code_spec[16] =
{
' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>', '@',
'!', '|'
diff --git a/src/syntax.h b/src/syntax.h
index c1bb9274d00..5949a95a73b 100644
--- a/src/syntax.h
+++ b/src/syntax.h
@@ -147,10 +147,6 @@ extern bool syntax_prefix_flag_p (int c);
extern unsigned char const syntax_spec_code[0400];
-/* Indexed by syntax code, give the letter that describes it. */
-
-extern char const syntax_code_spec[16];
-
/* Convert the byte offset BYTEPOS into a character position,
for the object recorded in gl_state with SETUP_SYNTAX_TABLE_FOR_OBJECT.
diff --git a/src/systime.h b/src/systime.h
index 41d728f1c29..75088bd4a62 100644
--- a/src/systime.h
+++ b/src/systime.h
@@ -91,7 +91,6 @@ extern Lisp_Object timespec_to_lisp (struct timespec);
extern bool list4_to_timespec (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, struct timespec *);
extern struct timespec lisp_time_argument (Lisp_Object);
-extern AVOID time_overflow (void);
extern double float_time (Lisp_Object);
extern void init_timefns (void);
extern void syms_of_timefns (void);
diff --git a/src/termhooks.h b/src/termhooks.h
index 93ac9ba0d2e..8c193914ba8 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -208,6 +208,25 @@ enum event_kind
representation of the dropped items.
.timestamp gives a timestamp (in
milliseconds) for the click. */
+#ifdef HAVE_X_WINDOWS
+ UNSUPPORTED_DROP_EVENT, /* Event sent when the regular C
+ drag-and-drop machinery could not
+ handle a drop to a window.
+
+ .code is the XID of the window that
+ could not be dropped to.
+
+ .arg is a list of the local value of
+ XdndSelection, a list of selection
+ targets, and the intended action to
+ be taken upon drop, and .timestamp
+ gives the timestamp where the drop
+ happened.
+
+ .x and .y give the coordinates of
+ the drop originating from the root
+ window. */
+#endif
USER_SIGNAL_EVENT, /* A user signal.
code is a number identifying it,
index into lispy_user_signals. */
@@ -373,9 +392,17 @@ struct input_event
when building events. Unfortunately some events have to pass much
more data than it's reasonable to pack directly into this structure. */
Lisp_Object arg;
+
+ /* The name of the device from which this event originated.
+
+ It can either be a string, or Qt, which means to use the name
+ "Virtual core pointer" for all events other than keystroke
+ events, and "Virtual core keyboard" for those. */
+ Lisp_Object device;
};
-#define EVENT_INIT(event) memset (&(event), 0, sizeof (struct input_event))
+#define EVENT_INIT(event) (memset (&(event), 0, sizeof (struct input_event)), \
+ (event).device = Qt)
/* Bits in the modifiers member of the input_event structure.
Note that reorder_modifiers assumes that the bits are in canonical
diff --git a/src/thread.c b/src/thread.c
index c6742341fb8..626d14aad0a 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -655,7 +655,7 @@ mark_one_thread (struct thread_state *thread)
mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
- mark_stack (thread->m_stack_bottom, stack_top);
+ mark_c_stack (thread->m_stack_bottom, stack_top);
for (struct handler *handler = thread->m_handlerlist;
handler; handler = handler->next)
diff --git a/src/thread.h b/src/thread.h
index ddba1a2d994..82c445ba7e7 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -33,6 +33,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "sysselect.h" /* FIXME */
#include "systhread.h"
+INLINE_HEADER_BEGIN
+
/* Byte-code interpreter thread state. */
struct bc_thread_state {
struct bc_frame *fp; /* current frame pointer */
@@ -315,4 +317,6 @@ int thread_select (select_func *func, int max_fds, fd_set *rfds,
bool thread_check_current_buffer (struct buffer *);
+INLINE_HEADER_END
+
#endif /* THREAD_H */
diff --git a/src/timefns.c b/src/timefns.c
index 9b5b090ba71..9e8592d35ac 100644
--- a/src/timefns.c
+++ b/src/timefns.c
@@ -342,7 +342,7 @@ init_timefns (void)
}
/* Report that a time value is out of range for Emacs. */
-void
+static AVOID
time_overflow (void)
{
error ("Specified time is not representable");
diff --git a/src/w32image.c b/src/w32image.c
index f3374dcfd30..1f7c4921b31 100644
--- a/src/w32image.c
+++ b/src/w32image.c
@@ -253,6 +253,7 @@ w32_can_use_native_image_api (Lisp_Object type)
|| EQ (type, Qpng)
|| EQ (type, Qgif)
|| EQ (type, Qtiff)
+ || EQ (type, Qbmp)
|| EQ (type, Qnative_image)))
{
/* GDI+ can also display BMP, Exif, ICON, WMF, and EMF images.
diff --git a/src/w32term.c b/src/w32term.c
index 9094843f60f..7837032304c 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -7744,9 +7744,10 @@ The native image API library used is GDI+ via GDIPLUS.DLL. This
library is available only since W2K, therefore this variable is
unconditionally set to nil on older systems. */);
- /* For now, disabled by default, since this is an experimental feature. */
-#if 0 && HAVE_NATIVE_IMAGE_API
- if (os_subtype == OS_9X)
+ /* Disabled for Cygwin/w32 builds, since they don't link against
+ -lgdiplus, see configure.ac. */
+#if defined WINDOWSNT && HAVE_NATIVE_IMAGE_API
+ if (os_subtype == OS_SUBTYPE_9X)
w32_use_native_image_api = 0;
else
w32_use_native_image_api = 1;
diff --git a/src/window.c b/src/window.c
index 59e21f11cb1..aed698d2a37 100644
--- a/src/window.c
+++ b/src/window.c
@@ -3181,14 +3181,6 @@ resize_root_window (Lisp_Object window, Lisp_Object delta,
horizontal, ignore, pixelwise);
}
-void
-sanitize_window_sizes (Lisp_Object horizontal)
-{
- /* Don't burp in temacs -nw before window.el is loaded. */
- if (!NILP (Fsymbol_function (Qwindow__sanitize_window_sizes)))
- call1 (Qwindow__sanitize_window_sizes, horizontal);
-}
-
static Lisp_Object
window_pixel_to_total (Lisp_Object frame, Lisp_Object horizontal)
@@ -6342,7 +6334,9 @@ as argument a number, nil, or `-'.
The next window is usually the one below the current one;
or the one at the top if the current one is at the bottom.
It is determined by the function `other-window-for-scrolling',
-which see. */)
+which see.
+
+Also see the `other-window-scroll-default' variable. */)
(Lisp_Object arg)
{
specpdl_ref count = SPECPDL_INDEX ();
@@ -8232,7 +8226,6 @@ syms_of_window (void)
DEFSYM (Qwindow__resize_root_window_vertically,
"window--resize-root-window-vertically");
DEFSYM (Qwindow__resize_mini_frame, "window--resize-mini-frame");
- DEFSYM (Qwindow__sanitize_window_sizes, "window--sanitize-window-sizes");
DEFSYM (Qwindow__pixel_to_total, "window--pixel-to-total");
DEFSYM (Qsafe, "safe");
DEFSYM (Qdisplay_buffer, "display-buffer");
diff --git a/src/window.h b/src/window.h
index 141c29e8100..94c9b7124f3 100644
--- a/src/window.h
+++ b/src/window.h
@@ -1188,7 +1188,6 @@ extern int window_scroll_margin (struct window *, enum margin_unit);
extern void temp_output_buffer_show (Lisp_Object);
extern void replace_buffer_in_windows (Lisp_Object);
extern void replace_buffer_in_windows_safely (Lisp_Object);
-extern void sanitize_window_sizes (Lisp_Object horizontal);
/* This looks like a setter, but it is a bit special. */
extern void wset_buffer (struct window *, Lisp_Object);
extern bool window_outdated (struct window *);
diff --git a/src/xdisp.c b/src/xdisp.c
index 5cb58391dde..6a0d0ea879a 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -10957,6 +10957,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
same directionality. */
it.bidi_p = false;
+ int start_x;
if (vertical_offset != 0)
{
int last_y;
@@ -10990,6 +10991,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
+ WINDOW_HEADER_LINE_HEIGHT (w));
start = clip_to_bounds (BEGV, IT_CHARPOS (it), ZV);
start_y = it.current_y;
+ start_x = it.current_x;
}
else
{
@@ -10999,11 +11001,52 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
reseat_at_previous_visible_line_start (&it);
it.current_x = it.hpos = 0;
if (IT_CHARPOS (it) != start)
- move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS);
+ {
+ void *it1data = NULL;
+ struct it it1;
+
+ SAVE_IT (it1, it, it1data);
+ move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS);
+ /* We could have a display property at START, in which case
+ asking move_it_to to stop at START will overshoot and
+ stop at position after START. So we try again, stopping
+ before START, and account for the width of the last
+ buffer position manually. */
+ if (IT_CHARPOS (it) > start && start > BEGV)
+ {
+ ptrdiff_t it1pos = IT_CHARPOS (it1);
+ int it1_x = it1.current_x;
+
+ RESTORE_IT (&it, &it1, it1data);
+ /* If START - 1 is the beginning of screen line,
+ move_it_to will not move, so we need to use a
+ lower-level move_it_in_display_line subroutine, and
+ tell it to move just 1 pixel, so it stops at the next
+ display element. */
+ if (start - 1 > it1pos)
+ move_it_to (&it, start - 1, -1, -1, -1, MOVE_TO_POS);
+ else
+ move_it_in_display_line (&it, start, it1_x + 1,
+ MOVE_TO_POS | MOVE_TO_X);
+ move_it_to (&it, start - 1, -1, -1, -1, MOVE_TO_POS);
+ start_x = it.current_x;
+ /* If we didn't change our buffer position, the pixel
+ width of what's here was not yet accounted for; do it
+ manually. */
+ if (IT_CHARPOS (it) == start - 1)
+ start_x += it.pixel_width;
+ }
+ else
+ {
+ start_x = it.current_x;
+ bidi_unshelve_cache (it1data, true);
+ }
+ }
+ else
+ start_x = it.current_x;
}
/* Now move to TO. */
- int start_x = it.current_x;
int move_op = MOVE_TO_POS | MOVE_TO_Y;
int to_x = -1;
it.current_y = start_y;
@@ -13209,9 +13252,12 @@ prepare_menu_bars (void)
{
Lisp_Object this = XCAR (ws);
struct window *w = XWINDOW (this);
+ /* Cf. conditions for redisplaying a window at the
+ beginning of redisplay_window. */
if (w->redisplay
|| XFRAME (w->frame)->redisplay
- || XBUFFER (w->contents)->text->redisplay)
+ || XBUFFER (w->contents)->text->redisplay
+ || BUF_PT (XBUFFER (w->contents)) != w->last_point)
{
windows = Fcons (this, windows);
}
@@ -15111,11 +15157,11 @@ get_tool_bar_item (struct frame *f, int x, int y, struct glyph **glyph,
Handle mouse button event on the tool-bar of frame F, at
frame-relative coordinates X/Y. DOWN_P is true for a button press,
false for button release. MODIFIERS is event modifiers for button
- release. */
+ release. DEVICE is the device the click came from, or Qt. */
void
-handle_tool_bar_click (struct frame *f, int x, int y, bool down_p,
- int modifiers)
+handle_tool_bar_click_with_device (struct frame *f, int x, int y, bool down_p,
+ int modifiers, Lisp_Object device)
{
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
struct window *w = XWINDOW (f->tool_bar_window);
@@ -15172,11 +15218,18 @@ handle_tool_bar_click (struct frame *f, int x, int y, bool down_p,
event.frame_or_window = frame;
event.arg = key;
event.modifiers = modifiers;
+ event.device = device;
kbd_buffer_store_event (&event);
f->last_tool_bar_item = -1;
}
}
+void
+handle_tool_bar_click (struct frame *f, int x, int y, bool down_p,
+ int modifiers)
+{
+ handle_tool_bar_click_with_device (f, x, y, down_p, modifiers, Qt);
+}
/* Possibly highlight a tool-bar item on frame F when mouse moves to
tool-bar window-relative coordinates X/Y. Called from
@@ -25009,7 +25062,10 @@ function `get-char-code-property' for a way to inquire about the
directionality is weak or neutral, such as numbers or punctuation
characters, can be forced to display in a very different place with
respect of its surrounding characters, so as to make the surrounding
-text confuse the user regarding what the text says. */)
+text confuse the user regarding what the text says.
+
+Also see the `highlight-confusing-reorderings' function, which can be
+useful in similar circumstances as this function. */)
(Lisp_Object from, Lisp_Object to, Lisp_Object object, Lisp_Object base_dir)
{
struct buffer *buf = current_buffer;
@@ -33850,7 +33906,8 @@ define_frame_cursor1 (struct frame *f, Emacs_Cursor cursor, Lisp_Object pointer)
return;
/* Do not change cursor shape while dragging mouse. */
- if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping))
+ if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping)
+ || EQ (track_mouse, Qdrag_source))
return;
if (!NILP (pointer))
@@ -35672,6 +35729,7 @@ be let-bound around code that needs to disable messages temporarily. */);
DEFSYM (Qdragging, "dragging");
DEFSYM (Qdropping, "dropping");
+ DEFSYM (Qdrag_source, "drag-source");
DEFSYM (Qdrag_with_mode_line, "drag-with-mode-line");
DEFSYM (Qdrag_with_header_line, "drag-with-header-line");
diff --git a/src/xfns.c b/src/xfns.c
index b5d0b2c54e8..2f90534c484 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -867,7 +867,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value
#else
Display *dpy = FRAME_X_DISPLAY (f);
PropMotifWmHints hints;
- Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False);
+ Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS;
memset (&hints, 0, sizeof(hints));
hints.flags = MWM_HINTS_DECORATIONS;
@@ -979,7 +979,7 @@ x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, Lisp_Object old_v
xg_set_no_focus_on_map (f, new_value);
#else /* not USE_GTK */
Display *dpy = FRAME_X_DISPLAY (f);
- Atom prop = XInternAtom (dpy, "_NET_WM_USER_TIME", False);
+ Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_net_wm_user_time;
Time timestamp = NILP (new_value) ? CurrentTime : 0;
XChangeProperty (dpy, FRAME_OUTER_WINDOW (f), prop,
@@ -3688,6 +3688,15 @@ setup_xi_event_mask (struct frame *f)
XISelectEvents (FRAME_X_DISPLAY (f),
FRAME_X_WINDOW (f),
&mask, 1);
+
+#if defined USE_GTK && !defined HAVE_GTK3
+ memset (m, 0, l);
+ XISetMask (m, XI_RawKeyPress);
+
+ XISelectEvents (FRAME_X_DISPLAY (f),
+ FRAME_DISPLAY_INFO (f)->root_window,
+ &mask, 1);
+#endif
unblock_input ();
}
#endif
@@ -3918,7 +3927,7 @@ x_window (struct frame *f, long window_prompting)
{
Display *dpy = FRAME_X_DISPLAY (f);
PropMotifWmHints hints;
- Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False);
+ Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS;
memset (&hints, 0, sizeof(hints));
hints.flags = MWM_HINTS_DECORATIONS;
@@ -4097,7 +4106,7 @@ x_window (struct frame *f)
{
Display *dpy = FRAME_X_DISPLAY (f);
PropMotifWmHints hints;
- Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False);
+ Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS;
memset (&hints, 0, sizeof(hints));
hints.flags = MWM_HINTS_DECORATIONS;
@@ -4435,9 +4444,7 @@ set_machine_and_pid_properties (struct frame *f)
unsigned long xpid = pid;
XChangeProperty (FRAME_X_DISPLAY (f),
FRAME_OUTER_WINDOW (f),
- XInternAtom (FRAME_X_DISPLAY (f),
- "_NET_WM_PID",
- False),
+ FRAME_DISPLAY_INFO (f)->Xatom_net_wm_pid,
XA_CARDINAL, 32, PropModeReplace,
(unsigned char *) &xpid, 1);
}
@@ -5461,6 +5468,7 @@ On MS Windows, this just returns nil. */)
static bool
x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect)
{
+#ifndef USE_XCB
Display *dpy = dpyinfo->display;
long offset, max_len;
Atom target_type, actual_type;
@@ -5514,6 +5522,69 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect)
x_uncatch_errors ();
return result;
+#else
+ xcb_get_property_cookie_t current_desktop_cookie;
+ xcb_get_property_cookie_t workarea_cookie;
+ xcb_get_property_reply_t *reply;
+ xcb_generic_error_t *error;
+ bool rc;
+ uint32_t current_workspace, *values;
+
+ current_desktop_cookie
+ = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) dpyinfo->root_window,
+ (xcb_atom_t) dpyinfo->Xatom_net_current_desktop,
+ XCB_ATOM_CARDINAL, 0, 1);
+
+ workarea_cookie
+ = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) dpyinfo->root_window,
+ (xcb_atom_t) dpyinfo->Xatom_net_workarea,
+ XCB_ATOM_CARDINAL, 0, UINT32_MAX);
+
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ current_desktop_cookie, &error);
+ rc = true;
+
+ if (!reply)
+ free (error), rc = false;
+ else
+ {
+ if (xcb_get_property_value_length (reply) != 4
+ || reply->type != XCB_ATOM_CARDINAL || reply->format != 32)
+ rc = false;
+ else
+ current_workspace = *(uint32_t *) xcb_get_property_value (reply);
+
+ free (reply);
+ }
+
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ workarea_cookie, &error);
+
+ if (!reply)
+ free (error), rc = false;
+ else
+ {
+ if (rc && reply->type == XCB_ATOM_CARDINAL && reply->format == 32
+ && (xcb_get_property_value_length (reply) / sizeof (uint32_t)
+ >= current_workspace + 4))
+ {
+ values = xcb_get_property_value (reply);
+
+ rect->x = values[current_workspace];
+ rect->y = values[current_workspace + 1];
+ rect->width = values[current_workspace + 2];
+ rect->height = values[current_workspace + 3];
+ }
+ else
+ rc = false;
+
+ free (reply);
+ }
+
+ return rc;
+#endif
}
#endif /* !(USE_GTK && HAVE_GTK3) */
@@ -5706,6 +5777,12 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo)
#if RANDR_MAJOR > 1 || (RANDR_MAJOR == 1 && RANDR_MINOR >= 5)
XRRMonitorInfo *rr_monitors;
+#ifdef USE_XCB
+ xcb_get_atom_name_cookie_t *atom_name_cookies;
+ xcb_get_atom_name_reply_t *reply;
+ xcb_generic_error_t *error;
+ int length;
+#endif
/* If RandR 1.5 or later is available, use that instead, as some
video drivers don't report correct dimensions via other versions
@@ -5724,6 +5801,9 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo)
goto fallback;
monitors = xzalloc (n_monitors * sizeof *monitors);
+#ifdef USE_XCB
+ atom_name_cookies = alloca (n_monitors * sizeof *atom_name_cookies);
+#endif
for (int i = 0; i < n_monitors; ++i)
{
@@ -5734,6 +5814,7 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo)
monitors[i].mm_width = rr_monitors[i].mwidth;
monitors[i].mm_height = rr_monitors[i].mheight;
+#ifndef USE_XCB
name = XGetAtomName (dpyinfo->display, rr_monitors[i].name);
if (name)
{
@@ -5742,6 +5823,11 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo)
}
else
monitors[i].name = xstrdup ("Unknown Monitor");
+#else
+ atom_name_cookies[i]
+ = xcb_get_atom_name (dpyinfo->xcb_connection,
+ (xcb_atom_t) rr_monitors[i].name);
+#endif
if (rr_monitors[i].primary)
primary = i;
@@ -5759,6 +5845,29 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo)
monitors[i].work = monitors[i].geom;
}
+#ifdef USE_XCB
+ for (int i = 0; i < n_monitors; ++i)
+ {
+ reply = xcb_get_atom_name_reply (dpyinfo->xcb_connection,
+ atom_name_cookies[i], &error);
+
+ if (!reply)
+ {
+ monitors[i].name = xstrdup ("Unknown monitor");
+ free (error);
+ }
+ else
+ {
+ length = xcb_get_atom_name_name_length (reply);
+ name = xmalloc (length + 1);
+ memcpy (name, xcb_get_atom_name_name (reply), length);
+ name[length] = '\0';
+ monitors[i].name = name;
+ free (reply);
+ }
+ }
+#endif
+
XRRFreeMonitors (rr_monitors);
randr15_p = true;
goto out;
@@ -6582,7 +6691,7 @@ The coordinates X and Y are interpreted in pixels relative to a position
return Qnil;
}
-DEFUN ("x-begin-drag", Fx_begin_drag, Sx_begin_drag, 1, 4, 0,
+DEFUN ("x-begin-drag", Fx_begin_drag, Sx_begin_drag, 1, 5, 0,
doc: /* Begin dragging contents on FRAME, with targets TARGETS.
TARGETS is a list of strings, which defines the X selection targets
that will be available to the drop target. Block until the mouse
@@ -6601,6 +6710,9 @@ can be one of the following:
`XdndSelection', and to delete whatever was saved into that
selection afterwards.
+`XdndActionPrivate' is also a valid return value, and means that the
+drop target chose to perform an unspecified or unknown action.
+
There are also some other valid values of ACTION that depend on
details of both the drop target's implementation details and that of
Emacs. For that reason, they are not mentioned here. Consult
@@ -6609,45 +6721,112 @@ https://freedesktop.org/wiki/Specifications/XDND/.
If RETURN-FRAME is non-nil, this function will return the frame if the
mouse pointer moves onto an Emacs frame, after first moving out of
-FRAME.
+FRAME. (This is not guaranteed to work on some systems.) If
+RETURN-FRAME is the symbol `now', any frame underneath the mouse
+pointer will be returned immediately.
+
+If ACTION is a list and not nil, its elements are assumed to be a cons
+of (ITEM . STRING), where ITEM is the name of an action, and STRING is
+a string describing ITEM to the user. The drop target is expected to
+prompt the user to choose between any of the actions in the list.
If ACTION is not specified or nil, `XdndActionCopy' is used
-instead. */)
+instead.
+
+If ALLOW-CURRENT-FRAME is not specified or nil, then the drop target
+is allowed to be FRAME. Otherwise, no action will be taken if the
+mouse buttons are released on top of FRAME. */)
(Lisp_Object targets, Lisp_Object action, Lisp_Object frame,
- Lisp_Object return_frame)
+ Lisp_Object return_frame, Lisp_Object allow_current_frame)
{
struct frame *f = decode_window_system_frame (frame);
- int ntargets = 0;
+ int ntargets = 0, nnames = 0;
+ ptrdiff_t len;
char *target_names[2048];
Atom *target_atoms;
- Lisp_Object lval;
+ Lisp_Object lval, original, tem, t1, t2;
Atom xaction;
+ Atom action_list[2048];
+ char *name_list[2048];
+ char *scratch;
+
+ USE_SAFE_ALLOCA;
CHECK_LIST (targets);
+ original = targets;
for (; CONSP (targets); targets = XCDR (targets))
{
CHECK_STRING (XCAR (targets));
+ maybe_quit ();
if (ntargets < 2048)
{
- target_names[ntargets] = SSDATA (XCAR (targets));
+ scratch = SSDATA (XCAR (targets));
+ len = strlen (scratch);
+ target_names[ntargets] = SAFE_ALLOCA (len + 1);
+ strncpy (target_names[ntargets], scratch, len + 1);
ntargets++;
}
else
error ("Too many targets");
}
+ CHECK_LIST_END (targets, original);
+
if (NILP (action) || EQ (action, QXdndActionCopy))
xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionCopy;
else if (EQ (action, QXdndActionMove))
xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove;
else if (EQ (action, QXdndActionLink))
xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink;
- else if (EQ (action, QXdndActionAsk))
- xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk;
else if (EQ (action, QXdndActionPrivate))
xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate;
+ else if (EQ (action, QXdndActionAsk))
+ xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk;
+ else if (CONSP (action))
+ {
+ xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk;
+ original = action;
+
+ CHECK_LIST (action);
+ for (; CONSP (action); action = XCDR (action))
+ {
+ maybe_quit ();
+ tem = XCAR (action);
+ CHECK_CONS (tem);
+ t1 = XCAR (tem);
+ t2 = XCDR (tem);
+ CHECK_SYMBOL (t1);
+ CHECK_STRING (t2);
+
+ if (nnames < 2048)
+ {
+ if (EQ (t1, QXdndActionCopy))
+ action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionCopy;
+ else if (EQ (t1, QXdndActionMove))
+ action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove;
+ else if (EQ (t1, QXdndActionLink))
+ action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink;
+ else if (EQ (t1, QXdndActionAsk))
+ action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk;
+ else if (EQ (t1, QXdndActionPrivate))
+ action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate;
+ else
+ signal_error ("Invalid drag-and-drop action", tem);
+
+ scratch = SSDATA (ENCODE_UTF_8 (t2));
+ len = strlen (scratch);
+ name_list[nnames] = SAFE_ALLOCA (len + 1);
+ strncpy (name_list[nnames], scratch, len + 1);
+
+ nnames++;
+ }
+ else
+ error ("Too many actions");
+ }
+ CHECK_LIST_END (action, original);
+ }
else
signal_error ("Invalid drag-and-drop action", action);
@@ -6660,8 +6839,11 @@ instead. */)
x_set_dnd_targets (target_atoms, ntargets);
lval = x_dnd_begin_drag_and_drop (f, FRAME_DISPLAY_INFO (f)->last_user_time,
- xaction, !NILP (return_frame));
+ xaction, return_frame, action_list,
+ (const char **) &name_list, nnames,
+ !NILP (allow_current_frame));
+ SAFE_FREE ();
return lval;
}
@@ -7002,6 +7184,13 @@ If WINDOW-ID is non-nil, change the property of that window instead
unsigned char *data;
int nelements;
Window target_window;
+#ifdef USE_XCB
+ xcb_intern_atom_cookie_t prop_atom_cookie;
+ xcb_intern_atom_cookie_t target_type_cookie;
+ xcb_intern_atom_reply_t *reply;
+ xcb_generic_error_t *generic_error;
+ bool rc;
+#endif
CHECK_STRING (prop);
@@ -7065,12 +7254,61 @@ If WINDOW-ID is non-nil, change the property of that window instead
}
block_input ();
+#ifndef USE_XCB
prop_atom = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (prop), False);
if (! NILP (type))
{
CHECK_STRING (type);
target_type = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (type), False);
}
+#else
+ rc = true;
+ prop_atom_cookie
+ = xcb_intern_atom (FRAME_DISPLAY_INFO (f)->xcb_connection,
+ 0, SBYTES (prop), SSDATA (prop));
+
+ if (!NILP (type))
+ {
+ CHECK_STRING (type);
+ target_type_cookie
+ = xcb_intern_atom (FRAME_DISPLAY_INFO (f)->xcb_connection,
+ 0, SBYTES (type), SSDATA (type));
+ }
+
+ reply = xcb_intern_atom_reply (FRAME_DISPLAY_INFO (f)->xcb_connection,
+ prop_atom_cookie, &generic_error);
+
+ if (reply)
+ {
+ prop_atom = (Atom) reply->atom;
+ free (reply);
+ }
+ else
+ {
+ free (generic_error);
+ rc = false;
+ }
+
+ if (!NILP (type))
+ {
+ reply = xcb_intern_atom_reply (FRAME_DISPLAY_INFO (f)->xcb_connection,
+ target_type_cookie, &generic_error);
+
+ if (reply)
+ {
+ target_type = (Atom) reply->atom;
+ free (reply);
+ }
+ else
+ {
+ free (generic_error);
+ rc = false;
+ }
+ }
+
+ if (!rc)
+ error ("Failed to intern type or property atom");
+#endif
XChangeProperty (FRAME_X_DISPLAY (f), target_window,
prop_atom, target_type, element_format, PropModeReplace,
diff --git a/src/xselect.c b/src/xselect.c
index cdc70d3e247..f855980a300 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -39,6 +39,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <X11/Xproto.h>
+static Time pending_dnd_time;
+
struct prop_location;
struct selection_data;
@@ -283,9 +285,13 @@ x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom)
return QTARGETS;
if (atom == dpyinfo->Xatom_NULL)
return QNULL;
+ if (atom == dpyinfo->Xatom_XdndSelection)
+ return QXdndSelection;
block_input ();
+ x_catch_errors (dpyinfo->display);
str = XGetAtomName (dpyinfo->display, atom);
+ x_uncatch_errors ();
unblock_input ();
TRACE1 ("XGetAtomName --> %s", str);
if (! str) return Qnil;
@@ -302,7 +308,7 @@ x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom)
Update the Vselection_alist so that we can reply to later requests for
our selection. */
-static void
+void
x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
Lisp_Object frame)
{
@@ -386,6 +392,9 @@ x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
CHECK_SYMBOL (target_type);
handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
+ if (CONSP (handler_fn))
+ handler_fn = XCDR (handler_fn);
+
if (!NILP (handler_fn))
value = call3 (handler_fn,
selection_symbol, (local_request ? Qnil : target_type),
@@ -766,6 +775,12 @@ x_handle_selection_request (struct selection_input_event *event)
if (!dpyinfo) goto DONE;
+ /* This is how the XDND protocol recommends dropping text onto a
+ target that doesn't support XDND. */
+ if (SELECTION_EVENT_TIME (event) == pending_dnd_time + 1
+ || SELECTION_EVENT_TIME (event) == pending_dnd_time + 2)
+ selection_symbol = QXdndSelection;
+
local_selection_data = LOCAL_SELECTION (selection_symbol, dpyinfo);
/* Decline if we don't own any selections. */
@@ -2666,6 +2681,12 @@ x_timestamp_for_selection (struct x_display_info *dpyinfo,
return value;
}
+void
+x_set_pending_dnd_time (Time time)
+{
+ pending_dnd_time = time;
+}
+
static void syms_of_xselect_for_pdumper (void);
void
@@ -2690,11 +2711,18 @@ syms_of_xselect (void)
DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
doc: /* An alist associating X Windows selection-types with functions.
These functions are called to convert the selection, with three args:
-the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
-a desired type to which the selection should be converted;
-and the local selection value (whatever was given to
+the name of the selection (typically `PRIMARY', `SECONDARY', or
+`CLIPBOARD'); a desired type to which the selection should be
+converted; and the local selection value (whatever was given to
`x-own-selection-internal').
+On X Windows, the function can also be a cons of (PREDICATE
+. FUNCTION), where PREDICATE determines whether or not the selection
+type will appear in the list of selection types available to other
+programs, and FUNCTION is the function which is actually called.
+PREDICATE is called with the same arguments as FUNCTION, and should
+return a non-nil value if the data type is to appear in that list.
+
The function should return the value to send to the X server
\(typically a string). A return value of nil
means that the conversion could not be done.
diff --git a/src/xterm.c b/src/xterm.c
index 6485374e2ae..2999480659b 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -142,14 +142,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
draw text in inverse video, and the cursor graphics context is used
to display the cursor in the most common case.
+ N.B. that some of the other window systems supported by use an
+ emulation of graphics contexts to hold the foreground and
+ background colors used in a glyph string, while the some others
+ ports compute those colors directly based on the colors of the
+ string's face and its highlight, but only on X are graphics
+ contexts a data structure inherent to the window system.
+
COLOR ALLOCATION
- In X, pixel values for colors are not guaranteed to correspond to
- their individual components. The rules for converting colors into
- pixel values are defined by the visual class of each display opened
- by Emacs. When a display is opened, a suitable visual is obtained
- from the X server, and a colormap is created based on that visual,
- which is then used for each frame created.
+ In (and only in) X, pixel values for colors are not guaranteed to
+ correspond to their individual components. The rules for
+ converting colors into pixel values are defined by the visual class
+ of each display opened by Emacs. When a display is opened, a
+ suitable visual is obtained from the X server, and a colormap is
+ created based on that visual, which is then used for each frame
+ created.
The colormap is then used by the X server to convert pixel values
from a frame created by Emacs into actual colors which are output
@@ -202,6 +210,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
which is used to determine the color values for given pixel
values.
+ In other window systems supported by Emacs, color allocation is
+ handled by the window system itself, to whom Emacs simply passes 24
+ (or 32-bit) RGB values.
+
OPTIONAL FEATURES
While X servers and client libraries tend to come with many
@@ -496,7 +508,44 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
compositing manager that the contents of the window now accurately
reflect the new size. The compositing manager will then display the
contents of the window, and the window manager might also postpone
- updating the window decorations until this moment. */
+ updating the window decorations until this moment.
+
+ DRAG AND DROP
+
+ Drag and drop in Emacs is implemented in two ways, depending on
+ which side initiated the drag-and-drop operation. When another X
+ client initiates a drag, and the user drops something on Emacs, a
+ `drag-n-drop-event' is sent with the contents of the ClientMessage,
+ and further processing (i.e. retrieving selection contents and
+ replying to the initiating client) is performed from Lisp inside
+ `x-dnd.el'.
+
+ However, dragging contents from Emacs is implemented entirely in C.
+ X Windows has several competing drag-and-drop protocols, of which
+ Emacs supports two: the XDND protocol (see
+ https://freedesktop.org/wiki/Specifications/XDND) and the Motif drag
+ and drop protocols. These protocols are based on the initiator
+ owning a special selection, specifying an action the recipient
+ should perform, grabbing the mouse, and sending various different
+ client messages to the toplevel window underneath the mouse as it
+ moves, or when buttons are released.
+
+ The Lisp interface to drag-and-drop is synchronous, and involves
+ running a nested event loop with some global state until the drag
+ finishes. When the mouse moves, Emacs looks up the toplevel window
+ underneath the pointer (the target window) either using a cache
+ provided by window managers that support the
+ _NET_WM_CLIENT_LIST_STACKING root window property, or by calling
+ XTranslateCoordinates in a loop until a toplevel window is found,
+ and sends various entry, exit, or motion events to the window
+ containing a list of targets the special selection can be converted
+ to, and the chosen action that the recipient should perform. The
+ recipient can then send messages in reply detailing the action it
+ has actually chosen to perform. Finally, when the mouse buttons are
+ released over the recipient window, Emacs sends a "drop" message to
+ the target window, waits for a reply, and returns the action
+ selected by the recipient to the Lisp code that initiated the
+ drag-and-drop operation. */
#include <config.h>
#include <stdlib.h>
@@ -542,6 +591,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <X11/extensions/Xinerama.h>
#endif
+#ifdef HAVE_XCOMPOSITE
+#include <X11/extensions/Xcomposite.h>
+#endif
+
+#ifdef HAVE_XSHAPE
+#include <X11/extensions/shape.h>
+#endif
+
+#ifdef HAVE_XCB_SHAPE
+#include <xcb/shape.h>
+#endif
+
/* Load sys/types.h if not already loaded.
In some systems loading it twice is suicidal. */
#ifndef makedev
@@ -555,6 +616,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <fcntl.h>
#include <errno.h>
#include <sys/stat.h>
+#include <flexmember.h>
#include "character.h"
#include "coding.h"
#include "composite.h"
@@ -650,6 +712,12 @@ bool use_xim = true;
bool use_xim = false; /* configure --without-xim */
#endif
+#if XCB_SHAPE_MAJOR_VERSION > 1 \
+ || (XCB_SHAPE_MAJOR_VERSION == 1 && \
+ XCB_SHAPE_MINOR_VERSION >= 1)
+#define HAVE_XCB_SHAPE_INPUT_RECTS
+#endif
+
#ifdef USE_GTK
/* GTK can't tolerate a call to `handle_interrupt' inside an event
signal handler, but we have to store input events inside the
@@ -783,45 +851,2221 @@ static void x_update_opaque_region (struct frame *, XEvent *);
static void x_scroll_bar_end_update (struct x_display_info *, struct scroll_bar *);
#endif
-static bool x_dnd_in_progress;
+#ifdef HAVE_X_I18N
+static int x_filter_event (struct x_display_info *, XEvent *);
+#endif
+
+/* Global state maintained during a drag-and-drop operation. */
+
+/* Flag that indicates if a drag-and-drop operation is in progress. */
+bool x_dnd_in_progress;
+
+/* The frame where the drag-and-drop operation originated. */
+struct frame *x_dnd_frame;
+
+/* Flag that indicates if a drag-and-drop operation is no longer in
+ progress, but the nested event loop should continue to run, because
+ handle_one_xevent is waiting for the drop target to return some
+ important information. */
+static bool x_dnd_waiting_for_finish;
+
+/* State of the Motif drop operation.
+
+ 0 means nothing has happened, i.e. the event loop should not wait
+ for the receiver to send any data. 1 means an XmDROP_START message
+ was sent to the target, but no response has yet been received. 2
+ means a response to our XmDROP_START message was received and the
+ target accepted the drop, so Emacs should start waiting for the
+ drop target to convert one of the special selections
+ XmTRANSFER_SUCCESS or XmTRANSFER_FAILURE. */
+static int x_dnd_waiting_for_motif_finish;
+
+/* Whether or not F1 was pressed during the drag-and-drop operation.
+
+ Motif programs rely on this to decide whether or not help
+ information about the drop site should be displayed. */
+static bool x_dnd_xm_use_help;
+
+/* Whether or not Motif drag initiator info was set up. */
+static bool x_dnd_motif_setup_p;
+
+/* The target window we are waiting for an XdndFinished message
+ from. */
+static Window x_dnd_pending_finish_target;
+
+/* The protocol version of that target window. */
+static int x_dnd_waiting_for_finish_proto;
+
+/* Whether or not it is OK for something to be dropped on the frame
+ where the drag-and-drop operation originated. */
+static bool x_dnd_allow_current_frame;
/* Whether or not to return a frame from `x_dnd_begin_drag_and_drop'.
0 means to do nothing. 1 means to wait for the mouse to first exit
`x_dnd_frame'. 2 means to wait for the mouse to move onto a frame,
- and 3 means to `x_dnd_return_frame_object'. */
+ and 3 means to return `x_dnd_return_frame_object'. */
static int x_dnd_return_frame;
+
+/* The frame that should be returned by
+ `x_dnd_begin_drag_and_drop'. */
static struct frame *x_dnd_return_frame_object;
+/* The last drop target window the mouse pointer moved over. This can
+ be different from `x_dnd_last_seen_toplevel' if that window had an
+ XdndProxy. */
static Window x_dnd_last_seen_window;
+
+/* The last toplevel the mouse pointer moved over. */
+static Window x_dnd_last_seen_toplevel;
+
+/* The window where the drop happened. Normally None, but it is set
+ when something is actually dropped. */
+static Window x_dnd_end_window;
+
+/* The XDND protocol version of `x_dnd_last_seen_window'. -1 means it
+ did not support XDND. */
static int x_dnd_last_protocol_version;
+
+/* The Motif drag and drop protocol style of `x_dnd_last_seen_window'.
+ XM_DRAG_STYLE_NONE means the window does not support the Motif drag
+ or drop protocol. XM_DRAG_STYLE_DROP_ONLY means the window does
+ not respond to any drag protocol messages, so only drops should be
+ sent. Any other value means that the window supports both the drag
+ and drop protocols. */
+static int x_dnd_last_motif_style;
+
+/* The timestamp where Emacs last acquired ownership of the
+ `XdndSelection' selection. */
static Time x_dnd_selection_timestamp;
+/* The drop target window to which the rectangle below applies. */
static Window x_dnd_mouse_rect_target;
+
+/* A rectangle where XDND position messages should not be sent to the
+ drop target if the mouse pointer lies within. */
static XRectangle x_dnd_mouse_rect;
+
+/* The action the drop target actually chose to perform.
+
+ Under XDND, this is set upon receiving the XdndFinished or
+ XdndStatus messages from the drop target.
+
+ Under Motif, this is changed upon receiving a XmDROP_START message
+ in reply to our own.
+
+ When dropping on a target that doesn't support any drag-and-drop
+ protocol, this is set to the atom XdndActionPrivate. */
static Atom x_dnd_action;
+
+/* The action we want the drop target to perform. The drop target may
+ elect to perform some different action, which is guaranteed to be
+ in `x_dnd_action' upon completion of a drop. */
static Atom x_dnd_wanted_action;
+/* Array of selection targets available to the drop target. */
static Atom *x_dnd_targets = NULL;
+
+/* The number of elements in that array. */
static int x_dnd_n_targets;
-static struct frame *x_dnd_frame;
+
+/* The old window attributes of the root window before the
+ drag-and-drop operation started. It is used to keep the old event
+ mask around, since that should be restored after the operation
+ finishes. */
+static XWindowAttributes x_dnd_old_window_attrs;
+
+/* Whether or not `x_dnd_cleaup_drag_and_drop' should actually clean
+ up the drag and drop operation. */
+static bool x_dnd_unwind_flag;
+
+/* The frame for which `x-dnd-movement-function' should be called. */
+static struct frame *x_dnd_movement_frame;
+
+/* The coordinates which the movement function should be called
+ with. */
+static int x_dnd_movement_x, x_dnd_movement_y;
+
+struct x_client_list_window
+{
+ Window window;
+ Display *dpy;
+ int x, y;
+ int width, height;
+ bool mapped_p;
+ long previous_event_mask;
+ unsigned long wm_state;
+
+ struct x_client_list_window *next;
+ uint8_t xm_protocol_style;
+
+ int frame_extents_left;
+ int frame_extents_right;
+ int frame_extents_top;
+ int frame_extents_bottom;
+
+#ifdef HAVE_XSHAPE
+ int border_width;
+
+ XRectangle *input_rects;
+ int n_input_rects;
+
+ XRectangle *bounding_rects;
+ int n_bounding_rects;
+#endif
+};
+
+static struct x_client_list_window *x_dnd_toplevels = NULL;
+static bool x_dnd_use_toplevels;
+
+/* Motif drag-and-drop protocol support. */
+
+typedef enum xm_byte_order
+ {
+ XM_BYTE_ORDER_LSB_FIRST = 'l',
+ XM_BYTE_ORDER_MSB_FIRST = 'B',
+#ifndef WORDS_BIGENDIAN
+ XM_BYTE_ORDER_CUR_FIRST = 'l',
+#else
+ XM_BYTE_ORDER_CUR_FIRST = 'B',
+#endif
+ } xm_byte_order;
+
+#define SWAPCARD32(l) \
+ { \
+ struct { unsigned t : 32; } bit32; \
+ char n, *tp = (char *) &bit32; \
+ bit32.t = l; \
+ n = tp[0]; tp[0] = tp[3]; tp[3] = n; \
+ n = tp[1]; tp[1] = tp[2]; tp[2] = n; \
+ l = bit32.t; \
+ }
+
+#define SWAPCARD16(s) \
+ { \
+ struct { unsigned t : 16; } bit16; \
+ char n, *tp = (char *) &bit16; \
+ bit16.t = s; \
+ n = tp[0]; tp[0] = tp[1]; tp[1] = n; \
+ s = bit16.t; \
+ }
+
+typedef struct xm_targets_table_header
+{
+ /* BYTE */ uint8_t byte_order;
+ /* BYTE */ uint8_t protocol;
+
+ /* CARD16 */ uint16_t target_list_count;
+ /* CARD32 */ uint32_t total_data_size;
+} xm_targets_table_header;
+
+typedef struct xm_targets_table_rec
+{
+ /* CARD16 */ uint16_t n_targets;
+ /* CARD32 */ uint32_t targets[FLEXIBLE_ARRAY_MEMBER];
+} xm_targets_table_rec;
+
+typedef struct xm_drop_start_message
+{
+ /* BYTE */ uint8_t reason;
+ /* BYTE */ uint8_t byte_order;
+
+ /* CARD16 */ uint16_t side_effects;
+ /* CARD32 */ uint32_t timestamp;
+ /* CARD16 */ uint16_t x, y;
+ /* CARD32 */ uint32_t index_atom;
+ /* CARD32 */ uint32_t source_window;
+} xm_drop_start_message;
+
+typedef struct xm_drop_start_reply
+{
+ /* BYTE */ uint8_t reason;
+ /* BYTE */ uint8_t byte_order;
+
+ /* CARD16 */ uint16_t side_effects;
+ /* CARD16 */ uint16_t better_x;
+ /* CARD16 */ uint16_t better_y;
+} xm_drop_start_reply;
+
+typedef struct xm_drag_initiator_info
+{
+ /* BYTE */ uint8_t byteorder;
+ /* BYTE */ uint8_t protocol;
+
+ /* CARD16 */ uint16_t table_index;
+ /* CARD32 */ uint32_t selection;
+} xm_drag_initiator_info;
+
+typedef struct xm_drag_receiver_info
+{
+ /* BYTE */ uint8_t byteorder;
+ /* BYTE */ uint8_t protocol;
+
+ /* BYTE */ uint8_t protocol_style;
+ /* BYTE */ uint8_t unspecified0;
+ /* CARD32 */ uint32_t unspecified1;
+ /* CARD32 */ uint32_t unspecified2;
+ /* CARD32 */ uint32_t unspecified3;
+} xm_drag_receiver_info;
+
+typedef struct xm_top_level_enter_message
+{
+ /* BYTE */ uint8_t reason;
+ /* BYTE */ uint8_t byteorder;
+
+ /* CARD16 */ uint16_t zero;
+ /* CARD32 */ uint32_t timestamp;
+ /* CARD32 */ uint32_t source_window;
+ /* CARD32 */ uint32_t index_atom;
+} xm_top_level_enter_message;
+
+typedef struct xm_drag_motion_message
+{
+ /* BYTE */ uint8_t reason;
+ /* BYTE */ uint8_t byteorder;
+
+ /* CARD16 */ uint16_t side_effects;
+ /* CARD32 */ uint32_t timestamp;
+ /* CARD16 */ uint16_t x, y;
+} xm_drag_motion_message;
+
+typedef struct xm_top_level_leave_message
+{
+ /* BYTE */ uint8_t reason;
+ /* BYTE */ uint8_t byteorder;
+
+ /* CARD16 */ uint16_t zero;
+ /* CARD32 */ uint32_t timestamp;
+ /* CARD32 */ uint32_t source_window;
+} xm_top_level_leave_message;
+
+#define XM_DRAG_SIDE_EFFECT(op, site, ops, act) \
+ ((op) | ((site) << 4) | ((ops) << 8) | ((act) << 12))
+
+/* Some of the macros below are temporarily unused. */
+
+#define XM_DRAG_SIDE_EFFECT_OPERATION(effect) ((effect) & 0xf)
+#define XM_DRAG_SIDE_EFFECT_SITE_STATUS(effect) (((effect) & 0xf0) >> 4)
+/* #define XM_DRAG_SIDE_EFFECT_OPERATIONS(effect) (((effect) & 0xf00) >> 8) */
+#define XM_DRAG_SIDE_EFFECT_DROP_ACTION(effect) (((effect) & 0xf000) >> 12)
+
+#define XM_DRAG_NOOP 0
+#define XM_DRAG_MOVE (1L << 0)
+#define XM_DRAG_COPY (1L << 1)
+#define XM_DRAG_LINK (1L << 2)
+
+#define XM_DROP_ACTION_DROP 0
+#define XM_DROP_ACTION_DROP_HELP 1
+#define XM_DROP_ACTION_DROP_CANCEL 2
+
+#define XM_DRAG_REASON(originator, code) ((code) | ((originator) << 7))
+#define XM_DRAG_REASON_ORIGINATOR(reason) (((reason) & 0x80) ? 1 : 0)
+#define XM_DRAG_REASON_CODE(reason) ((reason) & 0x7f)
+
+#define XM_DRAG_REASON_DROP_START 5
+#define XM_DRAG_REASON_TOP_LEVEL_ENTER 0
+#define XM_DRAG_REASON_TOP_LEVEL_LEAVE 1
+#define XM_DRAG_REASON_DRAG_MOTION 2
+#define XM_DRAG_ORIGINATOR_INITIATOR 0
+#define XM_DRAG_ORIGINATOR_RECEIVER 1
+
+#define XM_DRAG_STYLE_NONE 0
+
+#define XM_DRAG_STYLE_DROP_ONLY 1
+#define XM_DRAG_STYLE_DROP_ONLY_REC 3
+
+#define XM_DRAG_STYLE_DYNAMIC 5
+#define XM_DRAG_STYLE_DYNAMIC_REC 2
+#define XM_DRAG_STYLE_DYNAMIC_REC1 4
+
+#define XM_DRAG_STYLE_IS_DROP_ONLY(n) ((n) == XM_DRAG_STYLE_DROP_ONLY \
+ || (n) == XM_DRAG_STYLE_DROP_ONLY_REC)
+#define XM_DRAG_STYLE_IS_DYNAMIC(n) ((n) == XM_DRAG_STYLE_DYNAMIC \
+ || (n) == XM_DRAG_STYLE_DYNAMIC_REC \
+ || (n) == XM_DRAG_STYLE_DYNAMIC_REC1)
+
+#define XM_DROP_SITE_VALID 3
+/* #define XM_DROP_SITE_INVALID 2 */
+#define XM_DROP_SITE_NONE 1
+
+static uint8_t
+xm_side_effect_from_action (struct x_display_info *dpyinfo, Atom action)
+{
+ if (action == dpyinfo->Xatom_XdndActionCopy)
+ return XM_DRAG_COPY;
+ else if (action == dpyinfo->Xatom_XdndActionMove)
+ return XM_DRAG_MOVE;
+ else if (action == dpyinfo->Xatom_XdndActionLink)
+ return XM_DRAG_LINK;
+
+ return XM_DRAG_NOOP;
+}
+
+static int
+xm_read_targets_table_header (uint8_t *bytes, ptrdiff_t length,
+ xm_targets_table_header *header_return,
+ xm_byte_order *byteorder_return)
+{
+ if (length < 8)
+ return -1;
+
+ header_return->byte_order = *byteorder_return = *(bytes++);
+ header_return->protocol = *(bytes++);
+
+ header_return->target_list_count = *(uint16_t *) bytes;
+ header_return->total_data_size = *(uint32_t *) (bytes + 2);
+
+ if (header_return->byte_order != XM_BYTE_ORDER_CUR_FIRST)
+ {
+ SWAPCARD16 (header_return->target_list_count);
+ SWAPCARD32 (header_return->total_data_size);
+ }
+
+ header_return->byte_order = XM_BYTE_ORDER_CUR_FIRST;
+
+ return 8;
+}
+
+static xm_targets_table_rec *
+xm_read_targets_table_rec (uint8_t *bytes, ptrdiff_t length,
+ xm_byte_order byteorder)
+{
+ uint16_t nitems, i;
+ xm_targets_table_rec *rec;
+
+ if (length < 2)
+ return NULL;
+
+ nitems = *(uint16_t *) bytes;
+
+ if (length < 2 + nitems * 4)
+ return NULL;
+
+ if (byteorder != XM_BYTE_ORDER_CUR_FIRST)
+ SWAPCARD16 (nitems);
+
+ rec = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec,
+ targets, nitems * 4));
+ rec->n_targets = nitems;
+
+ for (i = 0; i < nitems; ++i)
+ {
+ rec->targets[i] = ((uint32_t *) (bytes + 2))[i];
+
+ if (byteorder != XM_BYTE_ORDER_CUR_FIRST)
+ SWAPCARD32 (rec->targets[i]);
+ }
+
+ return rec;
+}
+
+static int
+xm_find_targets_table_idx (xm_targets_table_header *header,
+ xm_targets_table_rec **recs,
+ Atom *sorted_targets, int ntargets)
+{
+ int j;
+ uint16_t i;
+ uint32_t *targets;
+
+ targets = alloca (sizeof *targets * ntargets);
+
+ for (j = 0; j < ntargets; ++j)
+ targets[j] = sorted_targets[j];
+
+ for (i = 0; i < header->target_list_count; ++i)
+ {
+ if (recs[i]->n_targets == ntargets
+ && !memcmp (&recs[i]->targets, targets,
+ sizeof *targets * ntargets))
+ return i;
+ }
+
+ return -1;
+}
+
+static int
+x_atoms_compare (const void *a, const void *b)
+{
+ return *(Atom *) a - *(Atom *) b;
+}
+
+static void
+xm_write_targets_table (Display *dpy, Window wdesc,
+ Atom targets_table_atom,
+ xm_targets_table_header *header,
+ xm_targets_table_rec **recs)
+{
+ uint8_t *header_buffer, *ptr, *rec_buffer;
+ ptrdiff_t rec_buffer_size;
+ uint16_t i, j;
+
+ header_buffer = alloca (8);
+ ptr = header_buffer;
+
+ *(header_buffer++) = header->byte_order;
+ *(header_buffer++) = header->protocol;
+ *((uint16_t *) header_buffer) = header->target_list_count;
+ *((uint32_t *) (header_buffer + 2)) = header->total_data_size;
+
+ rec_buffer = xmalloc (600);
+ rec_buffer_size = 600;
+
+ XChangeProperty (dpy, wdesc, targets_table_atom,
+ targets_table_atom, 8, PropModeReplace,
+ (unsigned char *) ptr, 8);
+
+ for (i = 0; i < header->target_list_count; ++i)
+ {
+ if (rec_buffer_size < 2 + recs[i]->n_targets * 4)
+ {
+ rec_buffer_size = 2 + recs[i]->n_targets * 4;
+ rec_buffer = xrealloc (rec_buffer, rec_buffer_size);
+ }
+
+ *((uint16_t *) rec_buffer) = recs[i]->n_targets;
+
+ for (j = 0; j < recs[i]->n_targets; ++j)
+ ((uint32_t *) (rec_buffer + 2))[j] = recs[i]->targets[j];
+
+ XChangeProperty (dpy, wdesc, targets_table_atom,
+ targets_table_atom, 8, PropModeAppend,
+ (unsigned char *) rec_buffer,
+ 2 + recs[i]->n_targets * 4);
+ }
+
+ xfree (rec_buffer);
+}
+
+static void
+xm_write_drag_initiator_info (Display *dpy, Window wdesc,
+ Atom prop_name, Atom type_name,
+ xm_drag_initiator_info *info)
+{
+ uint8_t *buf;
+
+ buf = alloca (8);
+ buf[0] = info->byteorder;
+ buf[1] = info->protocol;
+
+ *((uint16_t *) (buf + 2)) = info->table_index;
+ *((uint32_t *) (buf + 4)) = info->selection;
+
+ XChangeProperty (dpy, wdesc, prop_name, type_name, 8,
+ PropModeReplace, (unsigned char *) buf, 8);
+}
+
+static Window
+xm_get_drag_window (struct x_display_info *dpyinfo)
+{
+ Atom actual_type;
+ int rc, actual_format;
+ unsigned long nitems, bytes_remaining;
+ unsigned char *tmp_data = NULL;
+ Window drag_window;
+ XSetWindowAttributes attrs;
+ XWindowAttributes wattrs;
+ Display *temp_display;
+
+ drag_window = None;
+ rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window,
+ dpyinfo->Xatom_MOTIF_DRAG_WINDOW,
+ 0, 1, False, XA_WINDOW, &actual_type,
+ &actual_format, &nitems, &bytes_remaining,
+ &tmp_data) == Success;
+
+ if (rc)
+ {
+ if (actual_type == XA_WINDOW
+ && actual_format == 32 && nitems == 1)
+ {
+ drag_window = *(Window *) tmp_data;
+ x_catch_errors (dpyinfo->display);
+ XGetWindowAttributes (dpyinfo->display,
+ drag_window, &wattrs);
+ rc = !x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+
+ if (!rc)
+ drag_window = None;
+ }
+
+ if (tmp_data)
+ XFree (tmp_data);
+ }
+
+ if (drag_window == None)
+ {
+ block_input ();
+ unrequest_sigio ();
+ temp_display = XOpenDisplay (XDisplayString (dpyinfo->display));
+ request_sigio ();
+
+ if (!temp_display)
+ {
+ unblock_input ();
+ return None;
+ }
+
+ XGrabServer (temp_display);
+ XSetCloseDownMode (temp_display, RetainPermanent);
+ attrs.override_redirect = True;
+ drag_window = XCreateWindow (temp_display, DefaultRootWindow (temp_display),
+ -1, -1, 1, 1, 0, CopyFromParent, InputOnly,
+ CopyFromParent, CWOverrideRedirect, &attrs);
+ XChangeProperty (temp_display, DefaultRootWindow (temp_display),
+ XInternAtom (temp_display,
+ "_MOTIF_DRAG_WINDOW", False),
+ XA_WINDOW, 32, PropModeReplace,
+ (unsigned char *) &drag_window, 1);
+ XCloseDisplay (temp_display);
+
+ /* Make sure the drag window created is actually valid for the
+ current display, and the XOpenDisplay above didn't
+ accidentally connect to some other display. */
+ x_catch_errors (dpyinfo->display);
+ XGetWindowAttributes (dpyinfo->display,
+ drag_window, &wattrs);
+ rc = !x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+ unblock_input ();
+
+ /* We connected to the wrong display, so just give up. */
+ if (!rc)
+ drag_window = None;
+ }
+
+ return drag_window;
+}
+
+/* TODO: overflow checks when inserting targets. */
+static int
+xm_setup_dnd_targets (struct x_display_info *dpyinfo,
+ Atom *targets, int ntargets)
+{
+ Window drag_window;
+ Atom *targets_sorted, actual_type;
+ unsigned char *tmp_data = NULL;
+ unsigned long nitems, bytes_remaining;
+ int rc, actual_format, idx;
+ xm_targets_table_header header;
+ xm_targets_table_rec **recs;
+ xm_byte_order byteorder;
+ uint8_t *data;
+ ptrdiff_t total_bytes, total_items, i;
+
+ drag_window = xm_get_drag_window (dpyinfo);
+
+ if (drag_window == None || ntargets > 64)
+ return -1;
+
+ targets_sorted = xmalloc (sizeof *targets * ntargets);
+ memcpy (targets_sorted, targets,
+ sizeof *targets * ntargets);
+ qsort (targets_sorted, ntargets,
+ sizeof (Atom), x_atoms_compare);
+
+ XGrabServer (dpyinfo->display);
+ rc = XGetWindowProperty (dpyinfo->display, drag_window,
+ dpyinfo->Xatom_MOTIF_DRAG_TARGETS,
+ /* Do larger values occur in practice? */
+ 0L, 20000L, False,
+ dpyinfo->Xatom_MOTIF_DRAG_TARGETS,
+ &actual_type, &actual_format, &nitems,
+ &bytes_remaining, &tmp_data) == Success;
+
+ if (rc && tmp_data && !bytes_remaining
+ && actual_type == dpyinfo->Xatom_MOTIF_DRAG_TARGETS
+ && actual_format == 8)
+ {
+ data = (uint8_t *) tmp_data;
+ if (xm_read_targets_table_header ((uint8_t *) tmp_data,
+ nitems, &header,
+ &byteorder) == 8)
+ {
+ data += 8;
+ nitems -= 8;
+ total_bytes = 0;
+ total_items = 0;
+
+ /* The extra rec is used to store a new target list if a
+ preexisting one doesn't already exist. */
+ recs = xmalloc ((header.target_list_count + 1)
+ * sizeof *recs);
+
+ while (total_items < header.target_list_count)
+ {
+ recs[total_items] = xm_read_targets_table_rec (data + total_bytes,
+ nitems, byteorder);
+
+ if (!recs[total_items])
+ break;
+
+ total_bytes += 2 + recs[total_items]->n_targets * 4;
+ nitems -= 2 + recs[total_items]->n_targets * 4;
+ total_items++;
+ }
+
+ if (header.target_list_count != total_items
+ || header.total_data_size != 8 + total_bytes)
+ {
+ for (i = 0; i < total_items; ++i)
+ {
+ if (recs[i])
+ xfree (recs[i]);
+ else
+ break;
+ }
+
+ xfree (recs);
+
+ rc = false;
+ }
+ }
+ else
+ rc = false;
+ }
+ else
+ rc = false;
+
+ if (tmp_data)
+ XFree (tmp_data);
+
+ /* Now rc means whether or not the target lists weren't updated and
+ shouldn't be written to the drag window. */
+
+ if (!rc)
+ {
+ header.byte_order = XM_BYTE_ORDER_CUR_FIRST;
+ header.protocol = 0;
+ header.target_list_count = 1;
+ header.total_data_size = 8 + 2 + ntargets * 4;
+
+ recs = xmalloc (sizeof *recs);
+ recs[0] = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec,
+ targets, ntargets * 4));
+
+ recs[0]->n_targets = ntargets;
+
+ for (i = 0; i < ntargets; ++i)
+ recs[0]->targets[i] = targets_sorted[i];
+
+ idx = 0;
+ }
+ else
+ {
+ idx = xm_find_targets_table_idx (&header, recs,
+ targets_sorted,
+ ntargets);
+
+ if (idx == -1)
+ {
+ header.target_list_count++;
+ header.total_data_size += 2 + ntargets * 4;
+
+ recs[header.target_list_count - 1]
+ = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec,
+ targets, ntargets * 4));
+ recs[header.target_list_count - 1]->n_targets = ntargets;
+
+ for (i = 0; i < ntargets; ++i)
+ recs[header.target_list_count - 1]->targets[i] = targets_sorted[i];
+
+ idx = header.target_list_count - 1;
+ rc = false;
+ }
+ }
+
+ if (!rc)
+ xm_write_targets_table (dpyinfo->display, drag_window,
+ dpyinfo->Xatom_MOTIF_DRAG_TARGETS,
+ &header, recs);
+
+ XUngrabServer (dpyinfo->display);
+
+ for (i = 0; i < header.target_list_count; ++i)
+ xfree (recs[i]);
+
+ xfree (recs);
+ xfree (targets_sorted);
+
+ return idx;
+}
+
+static void
+xm_setup_drag_info (struct x_display_info *dpyinfo,
+ struct frame *source_frame)
+{
+ xm_drag_initiator_info drag_initiator_info;
+ int idx;
+
+ idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets,
+ x_dnd_n_targets);
+
+ if (idx != -1)
+ {
+ drag_initiator_info.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ drag_initiator_info.protocol = 0;
+ drag_initiator_info.table_index = idx;
+ drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection;
+
+ xm_write_drag_initiator_info (dpyinfo->display, FRAME_X_WINDOW (source_frame),
+ dpyinfo->Xatom_XdndSelection,
+ dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO,
+ &drag_initiator_info);
+
+ x_dnd_motif_setup_p = true;
+ }
+}
+
+static void
+xm_send_drop_message (struct x_display_info *dpyinfo, Window source,
+ Window target, xm_drop_start_message *dmsg)
+{
+ XEvent msg;
+
+ msg.xclient.type = ClientMessage;
+ msg.xclient.message_type
+ = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE;
+ msg.xclient.format = 8;
+ msg.xclient.window = target;
+ msg.xclient.data.b[0] = dmsg->reason;
+ msg.xclient.data.b[1] = dmsg->byte_order;
+ *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->side_effects;
+ *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp;
+ *((uint16_t *) &msg.xclient.data.b[8]) = dmsg->x;
+ *((uint16_t *) &msg.xclient.data.b[10]) = dmsg->y;
+ *((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom;
+ *((uint32_t *) &msg.xclient.data.b[16]) = dmsg->source_window;
+
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
+}
+
+static void
+xm_send_top_level_enter_message (struct x_display_info *dpyinfo, Window source,
+ Window target, xm_top_level_enter_message *dmsg)
+{
+ XEvent msg;
+
+ msg.xclient.type = ClientMessage;
+ msg.xclient.message_type
+ = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE;
+ msg.xclient.format = 8;
+ msg.xclient.window = target;
+ msg.xclient.data.b[0] = dmsg->reason;
+ msg.xclient.data.b[1] = dmsg->byteorder;
+ *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->zero;
+ *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp;
+ *((uint32_t *) &msg.xclient.data.b[8]) = dmsg->source_window;
+ *((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom;
+ msg.xclient.data.b[16] = 0;
+ msg.xclient.data.b[17] = 0;
+ msg.xclient.data.b[18] = 0;
+ msg.xclient.data.b[19] = 0;
+
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
+}
+
+static void
+xm_send_drag_motion_message (struct x_display_info *dpyinfo, Window source,
+ Window target, xm_drag_motion_message *dmsg)
+{
+ XEvent msg;
+
+ msg.xclient.type = ClientMessage;
+ msg.xclient.message_type
+ = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE;
+ msg.xclient.format = 8;
+ msg.xclient.window = target;
+ msg.xclient.data.b[0] = dmsg->reason;
+ msg.xclient.data.b[1] = dmsg->byteorder;
+ *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->side_effects;
+ *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp;
+ *((uint16_t *) &msg.xclient.data.b[8]) = dmsg->x;
+ *((uint16_t *) &msg.xclient.data.b[10]) = dmsg->y;
+ msg.xclient.data.b[12] = 0;
+ msg.xclient.data.b[13] = 0;
+ msg.xclient.data.b[14] = 0;
+ msg.xclient.data.b[15] = 0;
+ msg.xclient.data.b[16] = 0;
+ msg.xclient.data.b[17] = 0;
+ msg.xclient.data.b[18] = 0;
+ msg.xclient.data.b[19] = 0;
+
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
+}
+
+static void
+xm_send_top_level_leave_message (struct x_display_info *dpyinfo, Window source,
+ Window target, xm_top_level_leave_message *dmsg)
+{
+ XEvent msg;
+ xm_drag_motion_message mmsg;
+
+ /* Motif support for TOP_LEVEL_LEAVE has bitrotted, since these days
+ it assumes every client supports the preregister protocol style,
+ but we only support drop-only and dynamic. (Interestingly enough
+ LessTif works fine.) Sending an event with impossible
+ coordinates serves to get rid of any active drop site that might
+ still be around in the target drag context. */
+
+ if (x_dnd_fix_motif_leave)
+ {
+ mmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DRAG_MOTION);
+ mmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ mmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_NONE, XM_DRAG_NOOP,
+ XM_DROP_ACTION_DROP_CANCEL);
+ mmsg.timestamp = dmsg->timestamp;
+ mmsg.x = 65535;
+ mmsg.y = 65535;
+
+ xm_send_drag_motion_message (dpyinfo, source, target, &mmsg);
+ }
+
+ msg.xclient.type = ClientMessage;
+ msg.xclient.message_type
+ = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE;
+ msg.xclient.format = 8;
+ msg.xclient.window = target;
+ msg.xclient.data.b[0] = dmsg->reason;
+ msg.xclient.data.b[1] = dmsg->byteorder;
+ *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->zero;
+ *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp;
+ *((uint32_t *) &msg.xclient.data.b[8]) = dmsg->source_window;
+ msg.xclient.data.b[12] = 0;
+ msg.xclient.data.b[13] = 0;
+ msg.xclient.data.b[14] = 0;
+ msg.xclient.data.b[15] = 0;
+ msg.xclient.data.b[16] = 0;
+ msg.xclient.data.b[17] = 0;
+ msg.xclient.data.b[18] = 0;
+ msg.xclient.data.b[19] = 0;
+
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
+}
+
+static int
+xm_read_drop_start_reply (const XEvent *msg, xm_drop_start_reply *reply)
+{
+ const uint8_t *data;
+
+ data = (const uint8_t *) &msg->xclient.data.b[0];
+
+ if ((XM_DRAG_REASON_ORIGINATOR (data[0])
+ != XM_DRAG_ORIGINATOR_RECEIVER)
+ || (XM_DRAG_REASON_CODE (data[0])
+ != XM_DRAG_REASON_DROP_START))
+ return 1;
+
+ reply->reason = *(data++);
+ reply->byte_order = *(data++);
+ reply->side_effects = *(uint16_t *) data;
+ reply->better_x = *(uint16_t *) (data + 2);
+ reply->better_y = *(uint16_t *) (data + 4);
+
+ if (reply->byte_order != XM_BYTE_ORDER_CUR_FIRST)
+ {
+ SWAPCARD16 (reply->side_effects);
+ SWAPCARD16 (reply->better_x);
+ SWAPCARD16 (reply->better_y);
+ }
+
+ reply->byte_order = XM_BYTE_ORDER_CUR_FIRST;
+
+ return 0;
+}
+
+static int
+xm_read_drag_receiver_info (struct x_display_info *dpyinfo,
+ Window wdesc, xm_drag_receiver_info *rec)
+{
+ Atom actual_type;
+ int rc, actual_format;
+ unsigned long nitems, bytes_remaining;
+ unsigned char *tmp_data = NULL;
+ uint8_t *data;
+
+ x_catch_errors (dpyinfo->display);
+ rc = XGetWindowProperty (dpyinfo->display, wdesc,
+ dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO,
+ 0, 4, False,
+ dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO,
+ &actual_type, &actual_format, &nitems,
+ &bytes_remaining,
+ &tmp_data) == Success;
+
+ if (x_had_errors_p (dpyinfo->display)
+ || actual_format != 8 || nitems < 16 || !tmp_data
+ || actual_type != dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO)
+ rc = 0;
+ x_uncatch_errors_after_check ();
+
+ if (rc)
+ {
+ data = (uint8_t *) tmp_data;
+
+ rec->byteorder = data[0];
+ rec->protocol = data[1];
+ rec->protocol_style = data[2];
+ rec->unspecified0 = data[3];
+ rec->unspecified1 = *(uint32_t *) &data[4];
+ rec->unspecified2 = *(uint32_t *) &data[8];
+ rec->unspecified3 = *(uint32_t *) &data[12];
+
+ if (rec->byteorder != XM_BYTE_ORDER_CUR_FIRST)
+ {
+ SWAPCARD32 (rec->unspecified1);
+ SWAPCARD32 (rec->unspecified2);
+ SWAPCARD32 (rec->unspecified3);
+ }
+
+ rec->byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ }
+
+ if (tmp_data)
+ XFree (tmp_data);
+
+ return !rc;
+}
+
+static void
+x_dnd_send_xm_leave_for_drop (struct x_display_info *dpyinfo,
+ struct frame *f, Window wdesc,
+ Time timestamp)
+{
+ xm_top_level_leave_message lmsg;
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = timestamp;
+ lmsg.source_window = FRAME_X_WINDOW (f);
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (f),
+ wdesc, &lmsg);
+}
+
+static void
+x_dnd_free_toplevels (void)
+{
+ struct x_client_list_window *last;
+ struct x_client_list_window *tem = x_dnd_toplevels;
+
+ while (tem)
+ {
+ last = tem;
+ tem = tem->next;
+
+ x_catch_errors (last->dpy);
+ XSelectInput (last->dpy, last->window,
+ last->previous_event_mask);
+#ifdef HAVE_XSHAPE
+ XShapeSelectInput (last->dpy, last->window, None);
+#endif
+ x_uncatch_errors ();
+
+#ifdef HAVE_XSHAPE
+ if (last->n_input_rects != -1)
+ xfree (last->input_rects);
+ if (last->n_bounding_rects != -1)
+ xfree (last->bounding_rects);
+#endif
+
+ xfree (last);
+ }
+
+ x_dnd_toplevels = NULL;
+}
+
+static int
+x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
+{
+ Atom type;
+ Window *toplevels;
+ int format, rc;
+ unsigned long nitems, bytes_after;
+ unsigned long i;
+ unsigned char *data = NULL;
+ int frame_extents[4];
+
+#ifndef USE_XCB
+ int dest_x, dest_y;
+ unsigned long *wmstate;
+ unsigned long wmstate_items, extent_items;
+ unsigned char *wmstate_data = NULL, *extent_data = NULL;
+ XWindowAttributes attrs;
+ Window child;
+ xm_drag_receiver_info xm_info;
+#else
+ uint32_t *wmstate, *fextents;
+ uint8_t *xmdata;
+ xcb_get_window_attributes_cookie_t *window_attribute_cookies;
+ xcb_translate_coordinates_cookie_t *translate_coordinate_cookies;
+ xcb_get_property_cookie_t *get_property_cookies;
+ xcb_get_property_cookie_t *xm_property_cookies;
+ xcb_get_property_cookie_t *extent_property_cookies;
+ xcb_get_geometry_cookie_t *get_geometry_cookies;
+ xcb_get_window_attributes_reply_t attrs, *attrs_reply;
+ xcb_translate_coordinates_reply_t *coordinates_reply;
+ xcb_get_property_reply_t *property_reply;
+ xcb_get_property_reply_t *xm_property_reply;
+ xcb_get_property_reply_t *extent_property_reply;
+ xcb_get_geometry_reply_t *geometry_reply;
+ xcb_generic_error_t *error;
+#endif
+
+#ifdef HAVE_XCB_SHAPE
+ xcb_shape_get_rectangles_cookie_t *bounding_rect_cookies;
+ xcb_shape_get_rectangles_reply_t *bounding_rect_reply;
+ xcb_rectangle_iterator_t bounding_rect_iterator;
+#endif
+
+#ifdef HAVE_XCB_SHAPE_INPUT_RECTS
+ xcb_shape_get_rectangles_cookie_t *input_rect_cookies;
+ xcb_shape_get_rectangles_reply_t *input_rect_reply;
+ xcb_rectangle_iterator_t input_rect_iterator;
+#endif
+
+ struct x_client_list_window *tem;
+#if defined HAVE_XSHAPE && !defined HAVE_XCB_SHAPE_INPUT_RECTS
+ int count, ordering;
+ XRectangle *rects;
+#endif
+
+ rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window,
+ dpyinfo->Xatom_net_client_list_stacking,
+ 0, LONG_MAX, False, XA_WINDOW, &type,
+ &format, &nitems, &bytes_after, &data);
+
+ if (rc != Success)
+ return 1;
+
+ if (format != 32 || type != XA_WINDOW)
+ {
+ XFree (data);
+ return 1;
+ }
+
+ toplevels = (Window *) data;
+
+#ifdef USE_XCB
+ window_attribute_cookies
+ = alloca (sizeof *window_attribute_cookies * nitems);
+ translate_coordinate_cookies
+ = alloca (sizeof *translate_coordinate_cookies * nitems);
+ get_property_cookies
+ = alloca (sizeof *get_property_cookies * nitems);
+ xm_property_cookies
+ = alloca (sizeof *xm_property_cookies * nitems);
+ extent_property_cookies
+ = alloca (sizeof *extent_property_cookies * nitems);
+ get_geometry_cookies
+ = alloca (sizeof *get_geometry_cookies * nitems);
+
+#ifdef HAVE_XCB_SHAPE
+ bounding_rect_cookies
+ = alloca (sizeof *bounding_rect_cookies * nitems);
+#endif
+
+#ifdef HAVE_XCB_SHAPE_INPUT_RECTS
+ input_rect_cookies
+ = alloca (sizeof *input_rect_cookies * nitems);
+#endif
+
+ for (i = 0; i < nitems; ++i)
+ {
+ window_attribute_cookies[i]
+ = xcb_get_window_attributes (dpyinfo->xcb_connection,
+ (xcb_window_t) toplevels[i]);
+ translate_coordinate_cookies[i]
+ = xcb_translate_coordinates (dpyinfo->xcb_connection,
+ (xcb_window_t) toplevels[i],
+ (xcb_window_t) dpyinfo->root_window,
+ 0, 0);
+ get_property_cookies[i]
+ = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i],
+ (xcb_atom_t) dpyinfo->Xatom_wm_state, XCB_ATOM_ANY,
+ 0, 2);
+ xm_property_cookies[i]
+ = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i],
+ (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO,
+ (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO,
+ 0, 4);
+ extent_property_cookies[i]
+ = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) toplevels[i],
+ (xcb_atom_t) dpyinfo->Xatom_net_frame_extents,
+ XCB_ATOM_CARDINAL, 0, 4);
+ get_geometry_cookies[i]
+ = xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]);
+
+#ifdef HAVE_XCB_SHAPE
+ bounding_rect_cookies[i]
+ = xcb_shape_get_rectangles (dpyinfo->xcb_connection,
+ (xcb_window_t) toplevels[i],
+ XCB_SHAPE_SK_BOUNDING);
+#endif
+
+#ifdef HAVE_XCB_SHAPE_INPUT_RECTS
+ if (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1))
+ input_rect_cookies[i]
+ = xcb_shape_get_rectangles (dpyinfo->xcb_connection,
+ (xcb_window_t) toplevels[i],
+ XCB_SHAPE_SK_INPUT);
+#endif
+ }
+#endif
+
+ /* Actually right because _NET_CLIENT_LIST_STACKING has bottom-up
+ order. */
+ for (i = 0; i < nitems; ++i)
+ {
+ frame_extents[0] = 0;
+ frame_extents[1] = 0;
+ frame_extents[2] = 0;
+ frame_extents[3] = 0;
+
+#ifndef USE_XCB
+ x_catch_errors (dpyinfo->display);
+ rc = (XGetWindowAttributes (dpyinfo->display,
+ toplevels[i], &attrs)
+ && !x_had_errors_p (dpyinfo->display));
+
+ if (rc)
+ rc = (XTranslateCoordinates (dpyinfo->display, toplevels[i],
+ attrs.root, -attrs.border_width,
+ -attrs.border_width, &dest_x,
+ &dest_y, &child)
+ && !x_had_errors_p (dpyinfo->display));
+ if (rc)
+ rc = ((XGetWindowProperty (dpyinfo->display,
+ toplevels[i],
+ dpyinfo->Xatom_wm_state,
+ 0, 2, False, AnyPropertyType,
+ &type, &format, &wmstate_items,
+ &bytes_after, &wmstate_data)
+ == Success)
+ && !x_had_errors_p (dpyinfo->display)
+ && wmstate_data && wmstate_items == 2 && format == 32);
+
+ if (XGetWindowProperty (dpyinfo->display, toplevels[i],
+ dpyinfo->Xatom_net_frame_extents,
+ 0, 4, False, XA_CARDINAL, &type,
+ &format, &extent_items, &bytes_after,
+ &extent_data) == Success
+ && !x_had_errors_p (dpyinfo->display)
+ && extent_data && extent_items >= 4 && format == 32)
+ {
+ frame_extents[0] = ((unsigned long *) extent_data)[0];
+ frame_extents[1] = ((unsigned long *) extent_data)[1];
+ frame_extents[2] = ((unsigned long *) extent_data)[2];
+ frame_extents[3] = ((unsigned long *) extent_data)[3];
+ }
+
+ if (extent_data)
+ XFree (extent_data);
+
+ x_uncatch_errors ();
+#else
+ rc = true;
+
+ attrs_reply
+ = xcb_get_window_attributes_reply (dpyinfo->xcb_connection,
+ window_attribute_cookies[i],
+ &error);
+
+ if (!attrs_reply)
+ {
+ rc = false;
+ free (error);
+ }
+
+ coordinates_reply
+ = xcb_translate_coordinates_reply (dpyinfo->xcb_connection,
+ translate_coordinate_cookies[i],
+ &error);
+
+ if (!coordinates_reply)
+ {
+ rc = false;
+ free (error);
+ }
+
+ property_reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ get_property_cookies[i],
+ &error);
+
+ if (!property_reply)
+ {
+ rc = false;
+ free (error);
+ }
+
+ /* These requests don't set rc on failure because they aren't
+ required. */
+
+ xm_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ xm_property_cookies[i],
+ &error);
+
+ if (!xm_property_reply)
+ free (error);
+
+ extent_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ extent_property_cookies[i],
+ &error);
+
+ if (!extent_property_reply)
+ free (error);
+ else
+ {
+ if (xcb_get_property_value_length (extent_property_reply) == 16
+ && extent_property_reply->format == 32
+ && extent_property_reply->type == XCB_ATOM_CARDINAL)
+ {
+ fextents = xcb_get_property_value (extent_property_reply);
+ frame_extents[0] = fextents[0];
+ frame_extents[1] = fextents[1];
+ frame_extents[2] = fextents[2];
+ frame_extents[3] = fextents[3];
+ }
+
+ free (extent_property_reply);
+ }
+
+ if (property_reply
+ && (xcb_get_property_value_length (property_reply) != 8
+ || property_reply->format != 32))
+ rc = false;
+
+ geometry_reply = xcb_get_geometry_reply (dpyinfo->xcb_connection,
+ get_geometry_cookies[i],
+ &error);
+
+ if (!geometry_reply)
+ {
+ rc = false;
+ free (error);
+ }
+#endif
+
+ if (rc)
+ {
+#ifdef USE_XCB
+ wmstate = (uint32_t *) xcb_get_property_value (property_reply);
+ attrs = *attrs_reply;
+#else
+ wmstate = (unsigned long *) wmstate_data;
+#endif
+
+ tem = xmalloc (sizeof *tem);
+ tem->window = toplevels[i];
+ tem->dpy = dpyinfo->display;
+ tem->frame_extents_left = frame_extents[0];
+ tem->frame_extents_right = frame_extents[1];
+ tem->frame_extents_top = frame_extents[2];
+ tem->frame_extents_bottom = frame_extents[3];
+
+#ifndef USE_XCB
+ tem->x = dest_x;
+ tem->y = dest_y;
+ tem->width = attrs.width + attrs.border_width;
+ tem->height = attrs.height + attrs.border_width;
+ tem->mapped_p = (attrs.map_state != IsUnmapped);
+#else
+ tem->x = (coordinates_reply->dst_x
+ - geometry_reply->border_width);
+ tem->y = (coordinates_reply->dst_y
+ - geometry_reply->border_width);
+ tem->width = (geometry_reply->width
+ + geometry_reply->border_width);
+ tem->height = (geometry_reply->height
+ + geometry_reply->border_width);
+ tem->mapped_p = (attrs.map_state != XCB_MAP_STATE_UNMAPPED);
+#endif
+ tem->next = x_dnd_toplevels;
+ tem->previous_event_mask = attrs.your_event_mask;
+ tem->wm_state = wmstate[0];
+ tem->xm_protocol_style = XM_DRAG_STYLE_NONE;
+
+#ifndef USE_XCB
+ if (!xm_read_drag_receiver_info (dpyinfo, toplevels[i], &xm_info))
+ tem->xm_protocol_style = xm_info.protocol_style;
+#else
+ if (xm_property_reply
+ && xm_property_reply->format == 8
+ && xm_property_reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO
+ && xcb_get_property_value_length (xm_property_reply) >= 4)
+ {
+ xmdata = xcb_get_property_value (xm_property_reply);
+ tem->xm_protocol_style = xmdata[2];
+ }
+#endif
+
+#ifdef HAVE_XSHAPE
+#ifndef USE_XCB
+ tem->border_width = attrs.border_width;
+#else
+ tem->border_width = geometry_reply->border_width;
+#endif
+ tem->n_bounding_rects = -1;
+ tem->n_input_rects = -1;
+
+ if (dpyinfo->xshape_supported_p)
+ {
+ x_catch_errors (dpyinfo->display);
+ XShapeSelectInput (dpyinfo->display,
+ toplevels[i],
+ ShapeNotifyMask);
+ x_uncatch_errors ();
+
+#ifndef HAVE_XCB_SHAPE
+ x_catch_errors (dpyinfo->display);
+ rects = XShapeGetRectangles (dpyinfo->display,
+ toplevels[i],
+ ShapeBounding,
+ &count, &ordering);
+ rc = x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+
+ /* Does XShapeGetRectangles allocate anything upon an
+ error? */
+ if (!rc)
+ {
+ tem->n_bounding_rects = count;
+ tem->bounding_rects
+ = xmalloc (sizeof *tem->bounding_rects * count);
+ memcpy (tem->bounding_rects, rects,
+ sizeof *tem->bounding_rects * count);
+
+ XFree (rects);
+ }
+#else
+ bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ bounding_rect_cookies[i],
+ &error);
+
+ if (bounding_rect_reply)
+ {
+ bounding_rect_iterator
+ = xcb_shape_get_rectangles_rectangles_iterator (bounding_rect_reply);
+ tem->n_bounding_rects = bounding_rect_iterator.rem + 1;
+ tem->bounding_rects = xmalloc (tem->n_bounding_rects
+ * sizeof *tem->bounding_rects);
+ tem->n_bounding_rects = 0;
+
+ for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator))
+ {
+ tem->bounding_rects[tem->n_bounding_rects].x
+ = bounding_rect_iterator.data->x;
+ tem->bounding_rects[tem->n_bounding_rects].y
+ = bounding_rect_iterator.data->y;
+ tem->bounding_rects[tem->n_bounding_rects].width
+ = bounding_rect_iterator.data->width;
+ tem->bounding_rects[tem->n_bounding_rects].height
+ = bounding_rect_iterator.data->height;
+
+ tem->n_bounding_rects++;
+ }
+
+ free (bounding_rect_reply);
+ }
+ else
+ free (error);
+#endif
+
+#ifdef HAVE_XCB_SHAPE_INPUT_RECTS
+ if (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1))
+ {
+ input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ input_rect_cookies[i],
+ &error);
+
+ if (input_rect_reply)
+ {
+ input_rect_iterator
+ = xcb_shape_get_rectangles_rectangles_iterator (input_rect_reply);
+ tem->n_input_rects = input_rect_iterator.rem + 1;
+ tem->input_rects = xmalloc (tem->n_input_rects
+ * sizeof *tem->input_rects);
+ tem->n_input_rects = 0;
+
+ for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator))
+ {
+ tem->input_rects[tem->n_input_rects].x
+ = input_rect_iterator.data->x;
+ tem->input_rects[tem->n_input_rects].y
+ = input_rect_iterator.data->y;
+ tem->input_rects[tem->n_input_rects].width
+ = input_rect_iterator.data->width;
+ tem->input_rects[tem->n_input_rects].height
+ = input_rect_iterator.data->height;
+
+ tem->n_input_rects++;
+ }
+
+ free (input_rect_reply);
+ }
+ else
+ free (error);
+ }
+#else
+#ifdef ShapeInput
+ if (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1))
+ {
+ x_catch_errors (dpyinfo->display);
+ rects = XShapeGetRectangles (dpyinfo->display,
+ toplevels[i], ShapeInput,
+ &count, &ordering);
+ rc = x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+
+ /* Does XShapeGetRectangles allocate anything upon
+ an error? */
+ if (!rc)
+ {
+ tem->n_input_rects = count;
+ tem->input_rects
+ = xmalloc (sizeof *tem->input_rects * count);
+ memcpy (tem->input_rects, rects,
+ sizeof *tem->input_rects * count);
+
+ XFree (rects);
+ }
+ }
+#endif
+#endif
+ }
+
+ /* Handle the common case where the input shape equals the
+ bounding shape. */
+
+ if (tem->n_input_rects != -1
+ && tem->n_bounding_rects == tem->n_input_rects
+ && !memcmp (tem->bounding_rects, tem->input_rects,
+ tem->n_input_rects * sizeof *tem->input_rects))
+ {
+ xfree (tem->input_rects);
+ tem->n_input_rects = -1;
+ }
+
+ /* And the common case where there is no input rect and the
+ bouding rect equals the window dimensions. */
+
+ if (tem->n_input_rects == -1
+ && tem->n_bounding_rects == 1
+#ifdef USE_XCB
+ && tem->bounding_rects[0].width == (geometry_reply->width
+ + geometry_reply->border_width)
+ && tem->bounding_rects[0].height == (geometry_reply->height
+ + geometry_reply->border_width)
+ && tem->bounding_rects[0].x == -geometry_reply->border_width
+ && tem->bounding_rects[0].y == -geometry_reply->border_width
+#else
+ && tem->bounding_rects[0].width == attrs.width + attrs.border_width
+ && tem->bounding_rects[0].height == attrs.height + attrs.border_width
+ && tem->bounding_rects[0].x == -attrs.border_width
+ && tem->bounding_rects[0].y == -attrs.border_width
+#endif
+ )
+ {
+ xfree (tem->bounding_rects);
+ tem->n_bounding_rects = -1;
+ }
+#endif
+
+ x_catch_errors (dpyinfo->display);
+ XSelectInput (dpyinfo->display, toplevels[i],
+ (attrs.your_event_mask
+ | StructureNotifyMask
+ | PropertyChangeMask));
+ x_uncatch_errors ();
+
+ x_dnd_toplevels = tem;
+ }
+ else
+ {
+#ifdef HAVE_XCB_SHAPE
+ if (dpyinfo->xshape_supported_p)
+ {
+ bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ bounding_rect_cookies[i],
+ &error);
+
+ if (bounding_rect_reply)
+ free (bounding_rect_reply);
+ else
+ free (error);
+ }
+#endif
+
+#ifdef HAVE_XCB_SHAPE_INPUT_RECTS
+ if (dpyinfo->xshape_supported_p
+ && (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1)))
+ {
+ input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ input_rect_cookies[i],
+ &error);
+
+ if (input_rect_reply)
+ free (input_rect_reply);
+ else
+ free (error);
+ }
+#endif
+ }
+
+#ifdef USE_XCB
+ if (attrs_reply)
+ free (attrs_reply);
+
+ if (coordinates_reply)
+ free (coordinates_reply);
+
+ if (property_reply)
+ free (property_reply);
+
+ if (xm_property_reply)
+ free (xm_property_reply);
+
+ if (geometry_reply)
+ free (geometry_reply);
+#endif
+
+#ifndef USE_XCB
+ if (wmstate_data)
+ {
+ XFree (wmstate_data);
+ wmstate_data = NULL;
+ }
+#endif
+ }
+
+ return 0;
+}
#define X_DND_SUPPORTED_VERSION 5
+
static int x_dnd_get_window_proto (struct x_display_info *, Window);
static Window x_dnd_get_window_proxy (struct x_display_info *, Window);
+static void x_dnd_update_state (struct x_display_info *, Time);
+
+#ifdef USE_XCB
+static void
+x_dnd_get_proxy_proto (struct x_display_info *dpyinfo, Window wdesc,
+ Window *proxy_out, int *proto_out)
+{
+ xcb_get_property_cookie_t xdnd_proto_cookie;
+ xcb_get_property_cookie_t xdnd_proxy_cookie;
+ xcb_get_property_reply_t *reply;
+ xcb_generic_error_t *error;
+
+ if (proxy_out)
+ *proxy_out = None;
+
+ if (proto_out)
+ *proto_out = -1;
+
+ if (proxy_out)
+ xdnd_proxy_cookie = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) wdesc,
+ (xcb_atom_t) dpyinfo->Xatom_XdndProxy,
+ XCB_ATOM_WINDOW, 0, 1);
+
+ if (proto_out)
+ xdnd_proto_cookie = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) wdesc,
+ (xcb_atom_t) dpyinfo->Xatom_XdndAware,
+ XCB_ATOM_ATOM, 0, 1);
+
+ if (proxy_out)
+ {
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ xdnd_proxy_cookie, &error);
+
+ if (!reply)
+ free (error);
+ else
+ {
+ if (reply->format == 32
+ && reply->type == XCB_ATOM_WINDOW
+ && (xcb_get_property_value_length (reply) >= 4))
+ *proxy_out = *(xcb_window_t *) xcb_get_property_value (reply);
+
+ free (reply);
+ }
+ }
+
+ if (proto_out)
+ {
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ xdnd_proto_cookie, &error);
+
+ if (!reply)
+ free (error);
+ else
+ {
+ if (reply->format == 32
+ && reply->type == XCB_ATOM_ATOM
+ && (xcb_get_property_value_length (reply) >= 4))
+ *proto_out = (int) *(xcb_atom_t *) xcb_get_property_value (reply);
+
+ free (reply);
+ }
+ }
+}
+#endif
+
+#ifdef HAVE_XSHAPE
+static bool
+x_dnd_get_target_window_2 (XRectangle *rects, int nrects,
+ int x, int y)
+{
+ int i;
+ XRectangle *tem;
+
+ for (i = 0; i < nrects; ++i)
+ {
+ tem = &rects[i];
+
+ if (x >= tem->x && y >= tem->y
+ && x < tem->x + tem->width
+ && y < tem->y + tem->height)
+ return true;
+ }
+
+ return false;
+}
+#endif
+
+static Window
+x_dnd_get_target_window_1 (struct x_display_info *dpyinfo,
+ int root_x, int root_y, int *motif_out,
+ bool *extents_p)
+{
+ struct x_client_list_window *tem, *chosen = NULL;
+
+ /* Loop through x_dnd_toplevels until we find the toplevel where
+ root_x and root_y are. */
+
+ *motif_out = XM_DRAG_STYLE_NONE;
+ for (tem = x_dnd_toplevels; tem; tem = tem->next)
+ {
+ if (!tem->mapped_p || tem->wm_state != NormalState)
+ continue;
+
+ /* Test if the coordinates are inside the window's frame
+ extents, and return None in that case. */
+
+ *extents_p = true;
+ if (root_x > tem->x - tem->frame_extents_left
+ && root_x < tem->x
+ && root_y > tem->y - tem->frame_extents_top
+ && root_y < (tem->y + tem->height - 1
+ + tem->frame_extents_bottom))
+ return None;
+
+ if (root_x > tem->x + tem->width
+ && root_x < (tem->x + tem->width - 1
+ + tem->frame_extents_right)
+ && root_y > tem->y - tem->frame_extents_top
+ && root_y < (tem->y + tem->height - 1
+ + tem->frame_extents_bottom))
+ return None;
+
+ if (root_y > tem->y - tem->frame_extents_top
+ && root_y < tem->y
+ && root_x > tem->x - tem->frame_extents_left
+ && root_x < (tem->x + tem->width - 1
+ + tem->frame_extents_right))
+ return None;
+
+ if (root_y > tem->y + tem->height
+ && root_y < (tem->y + tem->height - 1
+ + tem->frame_extents_bottom)
+ && root_x >= tem->x - tem->frame_extents_left
+ && root_x < (tem->x + tem->width - 1
+ + tem->frame_extents_right))
+ return None;
+ *extents_p = false;
+
+ if (root_x >= tem->x && root_y >= tem->y
+ && root_x < tem->x + tem->width
+ && root_y < tem->y + tem->height)
+ {
+#ifdef HAVE_XSHAPE
+ if (tem->n_bounding_rects == -1)
+#endif
+ {
+ chosen = tem;
+ break;
+ }
+
+#ifdef HAVE_XSHAPE
+ if (x_dnd_get_target_window_2 (tem->bounding_rects,
+ tem->n_bounding_rects,
+ tem->border_width + root_x - tem->x,
+ tem->border_width + root_y - tem->y))
+ {
+ if (tem->n_input_rects == -1
+ || x_dnd_get_target_window_2 (tem->input_rects,
+ tem->n_input_rects,
+ tem->border_width + root_x - tem->x,
+ tem->border_width + root_y - tem->y))
+ {
+ chosen = tem;
+ break;
+ }
+ }
+#endif
+ }
+ }
+
+ if (chosen)
+ {
+ *motif_out = chosen->xm_protocol_style;
+ return chosen->window;
+ }
+ else
+ *motif_out = XM_DRAG_STYLE_NONE;
+
+ return None;
+}
+
+static int
+x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo,
+ Window window, int *wmstate_out,
+ int *proto_out, int *motif_out,
+ Window *proxy_out)
+{
+#ifndef USE_XCB
+ Atom type;
+ int format;
+ unsigned long nitems, bytes_after;
+ unsigned char *data = NULL;
+ xm_drag_receiver_info xm_info;
+#else
+ xcb_get_property_cookie_t wmstate_cookie;
+ xcb_get_property_cookie_t xdnd_proto_cookie;
+ xcb_get_property_cookie_t xdnd_proxy_cookie;
+ xcb_get_property_cookie_t xm_style_cookie;
+ xcb_get_property_reply_t *reply;
+ xcb_generic_error_t *error;
+ uint8_t *xmdata;
+#endif
+ int rc;
+
+#ifndef USE_XCB
+ x_catch_errors (dpyinfo->display);
+ rc = ((XGetWindowProperty (dpyinfo->display, window,
+ dpyinfo->Xatom_wm_state,
+ 0, 2, False, AnyPropertyType,
+ &type, &format, &nitems,
+ &bytes_after, &data)
+ == Success)
+ && !x_had_errors_p (dpyinfo->display)
+ && data && nitems == 2 && format == 32);
+ x_uncatch_errors ();
+
+ if (rc)
+ *wmstate_out = *(unsigned long *) data;
+
+ *proto_out = x_dnd_get_window_proto (dpyinfo, window);
+
+ if (!xm_read_drag_receiver_info (dpyinfo, window, &xm_info))
+ *motif_out = xm_info.protocol_style;
+ else
+ *motif_out = XM_DRAG_STYLE_NONE;
+
+ *proxy_out = x_dnd_get_window_proxy (dpyinfo, window);
+
+ if (data)
+ XFree (data);
+#else
+ rc = true;
+
+ wmstate_cookie = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) window,
+ (xcb_atom_t) dpyinfo->Xatom_wm_state,
+ XCB_ATOM_ANY, 0, 2);
+ xdnd_proto_cookie = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) window,
+ (xcb_atom_t) dpyinfo->Xatom_XdndAware,
+ XCB_ATOM_ATOM, 0, 1);
+ xdnd_proxy_cookie = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) window,
+ (xcb_atom_t) dpyinfo->Xatom_XdndProxy,
+ XCB_ATOM_WINDOW, 0, 1);
+ xm_style_cookie = xcb_get_property (dpyinfo->xcb_connection, 0,
+ (xcb_window_t) window,
+ (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO,
+ (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO,
+ 0, 4);
+
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ wmstate_cookie, &error);
+
+ if (!reply)
+ free (error), rc = false;
+ else
+ {
+ if (reply->format != 32
+ || xcb_get_property_value_length (reply) != 8)
+ rc = false;
+ else
+ *wmstate_out = *(uint32_t *) xcb_get_property_value (reply);
+
+ free (reply);
+ }
+
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ xdnd_proto_cookie, &error);
+
+ *proto_out = -1;
+ if (!reply)
+ free (error);
+ else
+ {
+ if (reply->format == 32
+ && xcb_get_property_value_length (reply) >= 4)
+ *proto_out = *(uint32_t *) xcb_get_property_value (reply);
+
+ free (reply);
+ }
+
+ *proxy_out = None;
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ xdnd_proxy_cookie, &error);
+
+ if (!reply)
+ free (error);
+ else
+ {
+ if (reply->format == 32
+ && reply->type == XCB_ATOM_WINDOW
+ && (xcb_get_property_value_length (reply) >= 4))
+ *proxy_out = *(xcb_window_t *) xcb_get_property_value (reply);
+
+ free (reply);
+ }
+
+ *motif_out = XM_DRAG_STYLE_NONE;
+
+ reply = xcb_get_property_reply (dpyinfo->xcb_connection,
+ xm_style_cookie, &error);
+
+ if (!reply)
+ free (error);
+ else
+ {
+ if (reply->format == 8
+ && reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO
+ && xcb_get_property_value_length (reply) >= 4)
+ {
+ xmdata = xcb_get_property_value (reply);
+ *motif_out = xmdata[2];
+ }
+
+ free (reply);
+ }
+#endif
+
+ return rc;
+}
+
+/* From the XDND protocol specification:
+
+ Dropping on windows that do not support XDND
+
+ Since middle clicking is the universal shortcut for pasting
+ in X, one can drop data into a window that does not support
+ XDND by:
+
+ 1. After the mouse has been released to trigger the drop,
+ obtain ownership of XA_PRIMARY.
+
+ 2. Send a ButtonPress event and then a ButtonRelease event to
+ the deepest subwindow containing the mouse to simulate a
+ middle click. The times for these events should be the time
+ of the actual button release +1 and +2, respectively. These
+ values will not be used by anybody else, so one can
+ unambiguously recognize the resulting `XConvertSelection'
+ request.
+
+ 3. If a request for XA_PRIMARY arrives bearing the timestamp
+ of either the ButtonPress or the ButtonRelease event, treat
+ it as a request for XdndSelection. Note that you must use
+ the X data types instead of the MIME types in this case.
+ (e.g. XA_STRING instead of text/plain). */
+void
+x_dnd_do_unsupported_drop (struct x_display_info *dpyinfo,
+ Lisp_Object frame, Lisp_Object value,
+ Lisp_Object targets, Window target_window,
+ int root_x, int root_y, Time before)
+{
+ XEvent event;
+ int dest_x, dest_y;
+ Window child_return, child;
+
+ event.xbutton.type = ButtonPress;
+ event.xbutton.serial = 0;
+ event.xbutton.send_event = True;
+ event.xbutton.display = dpyinfo->display;
+ event.xbutton.root = dpyinfo->root_window;
+ event.xbutton.x_root = root_x;
+ event.xbutton.y_root = root_y;
+
+ x_catch_errors (dpyinfo->display);
+
+ child = dpyinfo->root_window;
+ dest_x = root_x;
+ dest_y = root_y;
+
+ while (XTranslateCoordinates (dpyinfo->display, child,
+ child, root_x, root_y, &dest_x,
+ &dest_y, &child_return)
+ && child_return != None
+ && XTranslateCoordinates (dpyinfo->display, child,
+ child_return, root_x, root_y,
+ &dest_x, &dest_y, &child))
+ {
+ child = child_return;
+ root_x = dest_x;
+ root_y = dest_y;
+ }
+
+ if (CONSP (value))
+ x_own_selection (QPRIMARY, Fnth (make_fixnum (1), value),
+ frame);
+ else
+ x_own_selection (QPRIMARY, Qnil, frame);
+
+ event.xbutton.window = child;
+ event.xbutton.x = dest_x;
+ event.xbutton.y = dest_y;
+ event.xbutton.state = 0;
+ event.xbutton.button = 2;
+ event.xbutton.same_screen = True;
+ event.xbutton.time = before + 1;
+ event.xbutton.time = before + 2;
+
+ x_set_pending_dnd_time (before);
+
+ XSendEvent (dpyinfo->display, child,
+ True, ButtonPressMask, &event);
+ event.xbutton.type = ButtonRelease;
+ XSendEvent (dpyinfo->display, child,
+ True, ButtonReleaseMask, &event);
+
+ x_uncatch_errors ();
+}
+
+static void
+x_dnd_send_unsupported_drop (struct x_display_info *dpyinfo, Window target_window,
+ int root_x, int root_y, Time before)
+{
+ struct input_event ie;
+ Lisp_Object targets, arg;
+ int i;
+ char **atom_names, *name;
+
+ EVENT_INIT (ie);
+ targets = Qnil;
+ atom_names = alloca (sizeof *atom_names * x_dnd_n_targets);
+
+ if (!XGetAtomNames (dpyinfo->display, x_dnd_targets,
+ x_dnd_n_targets, atom_names))
+ return;
+
+ x_dnd_action = dpyinfo->Xatom_XdndActionPrivate;
+
+ for (i = x_dnd_n_targets; i > 0; --i)
+ {
+ targets = Fcons (build_string (atom_names[i - 1]),
+ targets);
+ XFree (atom_names[i - 1]);
+ }
+
+ name = XGetAtomName (dpyinfo->display,
+ x_dnd_wanted_action);
+
+ if (name)
+ {
+ arg = intern (name);
+ XFree (name);
+ }
+ else
+ arg = Qnil;
+
+ ie.kind = UNSUPPORTED_DROP_EVENT;
+ ie.code = (unsigned) target_window;
+ ie.arg = list3 (assq_no_quit (QXdndSelection,
+ dpyinfo->terminal->Vselection_alist),
+ targets, arg);
+ ie.timestamp = before;
+
+ XSETINT (ie.x, root_x);
+ XSETINT (ie.y, root_y);
+ XSETFRAME (ie.frame_or_window, x_dnd_frame);
+
+ kbd_buffer_store_event (&ie);
+}
static Window
x_dnd_get_target_window (struct x_display_info *dpyinfo,
- int root_x, int root_y, int *proto_out)
+ int root_x, int root_y, int *proto_out,
+ int *motif_out, Window *toplevel_out)
{
Window child_return, child, dummy, proxy;
- int dest_x_return, dest_y_return, rc, proto;
+ int dest_x_return, dest_y_return, rc, proto, motif;
+ bool extents_p;
+#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2)
+ Window overlay_window;
+ XWindowAttributes attrs;
+#endif
+ int wmstate;
+
child_return = dpyinfo->root_window;
dest_x_return = root_x;
dest_y_return = root_y;
proto = -1;
+ *motif_out = XM_DRAG_STYLE_NONE;
+ *toplevel_out = None;
+
+ if (x_dnd_use_toplevels)
+ {
+ extents_p = false;
+ child = x_dnd_get_target_window_1 (dpyinfo, root_x,
+ root_y, motif_out,
+ &extents_p);
+
+ if (!x_dnd_allow_current_frame
+ && FRAME_X_WINDOW (x_dnd_frame) == child)
+ *motif_out = XM_DRAG_STYLE_NONE;
+
+ *toplevel_out = child;
+
+ if (child != None)
+ {
+#ifndef USE_XCB
+ proxy = x_dnd_get_window_proxy (dpyinfo, child);
+#else
+ x_dnd_get_proxy_proto (dpyinfo, child, &proxy, proto_out);
+#endif
+
+ if (proxy != None)
+ {
+ proto = x_dnd_get_window_proto (dpyinfo, proxy);
+
+ if (proto != -1)
+ {
+ *proto_out = proto;
+ return proxy;
+ }
+ }
+
+#ifndef USE_XCB
+ *proto_out = x_dnd_get_window_proto (dpyinfo, child);
+#endif
+ return child;
+ }
+
+ if (extents_p)
+ {
+ *proto_out = -1;
+ *motif_out = XM_DRAG_STYLE_NONE;
+ *toplevel_out = None;
+
+ return None;
+ }
+
+ /* Then look at the composite overlay window. */
+#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2)
+ if (dpyinfo->composite_supported_p
+ && (dpyinfo->composite_major > 0
+ || dpyinfo->composite_minor > 2))
+ {
+ if (XGetSelectionOwner (dpyinfo->display,
+ dpyinfo->Xatom_NET_WM_CM_Sn) != None)
+ {
+ x_catch_errors (dpyinfo->display);
+ overlay_window = XCompositeGetOverlayWindow (dpyinfo->display,
+ dpyinfo->root_window);
+ XCompositeReleaseOverlayWindow (dpyinfo->display,
+ dpyinfo->root_window);
+ if (!x_had_errors_p (dpyinfo->display))
+ {
+ XGetWindowAttributes (dpyinfo->display, overlay_window, &attrs);
+
+ if (attrs.map_state == IsViewable)
+ {
+ proxy = x_dnd_get_window_proxy (dpyinfo, overlay_window);
+
+ if (proxy != None)
+ {
+ proto = x_dnd_get_window_proto (dpyinfo, proxy);
+
+ if (proto != -1)
+ {
+ *proto_out = proto;
+ *toplevel_out = overlay_window;
+ x_uncatch_errors_after_check ();
+
+ return proxy;
+ }
+ }
+ }
+ }
+ x_uncatch_errors_after_check ();
+ }
+ }
+#endif
+
+ /* Now look for an XdndProxy on the root window. */
+
+ proxy = x_dnd_get_window_proxy (dpyinfo, dpyinfo->root_window);
+
+ if (proxy != None)
+ {
+ proto = x_dnd_get_window_proto (dpyinfo, dpyinfo->root_window);
+
+ if (proto != -1)
+ {
+ *toplevel_out = dpyinfo->root_window;
+ *proto_out = proto;
+ return proxy;
+ }
+ }
+
+ /* No toplevel was found and the overlay and root windows were
+ not proxies, so return None. */
+ *proto_out = -1;
+ *toplevel_out = dpyinfo->root_window;
+ return None;
+ }
/* Not strictly necessary, but satisfies GCC. */
child = dpyinfo->root_window;
@@ -843,31 +3087,35 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo,
break;
}
- proxy = x_dnd_get_window_proxy (dpyinfo, child_return);
-
- if (proxy != None)
+ if (child_return)
{
- proto = x_dnd_get_window_proto (dpyinfo, proxy);
-
- if (proto != -1)
+ if (x_dnd_get_wm_state_and_proto (dpyinfo, child_return,
+ &wmstate, &proto, &motif,
+ &proxy)
+ /* `proto' and `motif' are set by x_dnd_get_wm_state
+ even if getting the wm state failed. */
+ || proto != -1 || motif != XM_DRAG_STYLE_NONE)
{
*proto_out = proto;
+ *motif_out = motif;
+ *toplevel_out = child_return;
+ x_uncatch_errors ();
- x_uncatch_errors_after_check ();
- return proxy;
+ return child_return;
}
- }
- if (child_return)
- {
- proto = x_dnd_get_window_proto (dpyinfo, child_return);
-
- if (proto != -1)
+ if (proxy != None)
{
- *proto_out = proto;
- x_uncatch_errors_after_check ();
+ proto = x_dnd_get_window_proto (dpyinfo, proxy);
- return child_return;
+ if (proto != -1)
+ {
+ *proto_out = proto;
+ *toplevel_out = child_return;
+
+ x_uncatch_errors ();
+ return proxy;
+ }
}
rc = XTranslateCoordinates (dpyinfo->display,
@@ -880,6 +3128,7 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo,
{
x_uncatch_errors_after_check ();
*proto_out = -1;
+ *toplevel_out = dpyinfo->root_window;
return None;
}
}
@@ -887,8 +3136,92 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo,
x_uncatch_errors_after_check ();
}
+#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2)
+ if (child != dpyinfo->root_window)
+ {
+#endif
+ if (child != None)
+ {
+ proxy = x_dnd_get_window_proxy (dpyinfo, child);
+
+ if (proxy)
+ {
+ proto = x_dnd_get_window_proto (dpyinfo, proxy);
+
+ if (proto != -1)
+ {
+ *proto_out = proto;
+ *toplevel_out = child;
+ return proxy;
+ }
+ }
+ }
+
+ *proto_out = x_dnd_get_window_proto (dpyinfo, child);
+ return child;
+#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2)
+ }
+ else if (dpyinfo->composite_supported_p
+ && (dpyinfo->composite_major > 0
+ || dpyinfo->composite_minor > 2))
+ {
+ /* Only do this if a compositing manager is present. */
+ if (XGetSelectionOwner (dpyinfo->display,
+ dpyinfo->Xatom_NET_WM_CM_Sn) != None)
+ {
+ x_catch_errors (dpyinfo->display);
+ overlay_window = XCompositeGetOverlayWindow (dpyinfo->display,
+ dpyinfo->root_window);
+ XCompositeReleaseOverlayWindow (dpyinfo->display,
+ dpyinfo->root_window);
+ if (!x_had_errors_p (dpyinfo->display))
+ {
+ XGetWindowAttributes (dpyinfo->display, overlay_window, &attrs);
+
+ if (attrs.map_state == IsViewable)
+ {
+ proxy = x_dnd_get_window_proxy (dpyinfo, overlay_window);
+
+ if (proxy != None)
+ {
+ proto = x_dnd_get_window_proto (dpyinfo, proxy);
+
+ if (proto != -1)
+ {
+ *proto_out = proto;
+ *toplevel_out = overlay_window;
+ x_uncatch_errors_after_check ();
+
+ return proxy;
+ }
+ }
+ }
+ }
+ x_uncatch_errors_after_check ();
+ }
+ }
+
+ if (child != None)
+ {
+ proxy = x_dnd_get_window_proxy (dpyinfo, child);
+
+ if (proxy)
+ {
+ proto = x_dnd_get_window_proto (dpyinfo, proxy);
+
+ if (proto != -1)
+ {
+ *toplevel_out = child;
+ *proto_out = proto;
+ return proxy;
+ }
+ }
+ }
+
*proto_out = x_dnd_get_window_proto (dpyinfo, child);
+ *toplevel_out = child;
return child;
+#endif
}
static Window
@@ -896,7 +3229,7 @@ x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc)
{
int rc, actual_format;
unsigned long actual_size, bytes_remaining;
- unsigned char *tmp_data;
+ unsigned char *tmp_data = NULL;
XWindowAttributes attrs;
Atom actual_type;
Window proxy;
@@ -912,12 +3245,12 @@ x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc)
if (!x_had_errors_p (dpyinfo->display)
&& rc == Success
+ && tmp_data
&& actual_type == XA_WINDOW
&& actual_format == 32
&& actual_size == 1)
{
proxy = *(Window *) tmp_data;
- XFree (tmp_data);
/* Verify the proxy window exists. */
XGetWindowAttributes (dpyinfo->display, proxy, &attrs);
@@ -925,6 +3258,9 @@ x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc)
if (x_had_errors_p (dpyinfo->display))
proxy = None;
}
+
+ if (tmp_data)
+ XFree (tmp_data);
x_uncatch_errors_after_check ();
return proxy;
@@ -934,12 +3270,13 @@ static int
x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc)
{
Atom actual, value;
- unsigned char *tmp_data;
+ unsigned char *tmp_data = NULL;
int rc, format;
unsigned long n, left;
bool had_errors;
- if (wdesc == None || wdesc == FRAME_X_WINDOW (x_dnd_frame))
+ if (wdesc == None || (!x_dnd_allow_current_frame
+ && wdesc == FRAME_OUTER_WINDOW (x_dnd_frame)))
return -1;
x_catch_errors (dpyinfo->display);
@@ -949,13 +3286,18 @@ x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc)
had_errors = x_had_errors_p (dpyinfo->display);
x_uncatch_errors_after_check ();
- if (had_errors || rc != Success || actual != XA_ATOM || format != 32 || n < 1)
- return -1;
+ if (had_errors || rc != Success || actual != XA_ATOM || format != 32 || n < 1
+ || !tmp_data)
+ {
+ if (tmp_data)
+ XFree (tmp_data);
+ return -1;
+ }
value = (int) *(Atom *) tmp_data;
XFree (tmp_data);
- return (int) value;
+ return min (X_DND_SUPPORTED_VERSION, (int) value);
}
static void
@@ -965,6 +3307,9 @@ x_dnd_send_enter (struct frame *f, Window target, int supported)
int i;
XEvent msg;
+ if (x_top_window_to_frame (dpyinfo, target))
+ return;
+
msg.xclient.type = ClientMessage;
msg.xclient.message_type = dpyinfo->Xatom_XdndEnter;
msg.xclient.format = 32;
@@ -986,7 +3331,9 @@ x_dnd_send_enter (struct frame *f, Window target, int supported)
PropModeReplace, (unsigned char *) x_dnd_targets,
x_dnd_n_targets);
- XSendEvent (FRAME_X_DISPLAY (f), target, False, 0, &msg);
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
}
static void
@@ -996,6 +3343,23 @@ x_dnd_send_position (struct frame *f, Window target, int supported,
{
struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
XEvent msg;
+ struct frame *target_frame;
+ int dest_x, dest_y;
+ Window child_return;
+
+ target_frame = x_top_window_to_frame (dpyinfo, target);
+
+ if (target_frame && XTranslateCoordinates (dpyinfo->display,
+ dpyinfo->root_window,
+ FRAME_X_WINDOW (target_frame),
+ root_x, root_y, &dest_x,
+ &dest_y, &child_return))
+ {
+ x_dnd_movement_frame = target_frame;
+ x_dnd_movement_x = dest_x;
+ x_dnd_movement_y = dest_y;
+ return;
+ }
if (target == x_dnd_mouse_rect_target
&& x_dnd_mouse_rect.width
@@ -1026,7 +3390,9 @@ x_dnd_send_position (struct frame *f, Window target, int supported,
if (supported >= 4)
msg.xclient.data.l[4] = action;
- XSendEvent (FRAME_X_DISPLAY (f), target, False, 0, &msg);
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
}
static void
@@ -1035,6 +3401,9 @@ x_dnd_send_leave (struct frame *f, Window target)
struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
XEvent msg;
+ if (x_top_window_to_frame (dpyinfo, target))
+ return;
+
msg.xclient.type = ClientMessage;
msg.xclient.message_type = dpyinfo->Xatom_XdndLeave;
msg.xclient.format = 32;
@@ -1045,15 +3414,82 @@ x_dnd_send_leave (struct frame *f, Window target)
msg.xclient.data.l[3] = 0;
msg.xclient.data.l[4] = 0;
- XSendEvent (FRAME_X_DISPLAY (f), target, False, 0, &msg);
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
}
-static void
+static bool
x_dnd_send_drop (struct frame *f, Window target, Time timestamp,
int supported)
{
struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
XEvent msg;
+ struct input_event ie;
+ struct frame *self_frame;
+ int root_x, root_y, win_x, win_y, i;
+ unsigned int mask;
+ Window root, child;
+ Lisp_Object lval;
+ char **atom_names;
+ char *name;
+
+ self_frame = x_top_window_to_frame (dpyinfo, target);
+
+ if (self_frame)
+ {
+ if (!x_dnd_allow_current_frame
+ && self_frame == x_dnd_frame)
+ return false;
+
+ /* Send a special drag-and-drop event when dropping on top of an
+ Emacs frame to avoid all the overhead involved with sending
+ client events. */
+ EVENT_INIT (ie);
+
+ if (XQueryPointer (dpyinfo->display, FRAME_X_WINDOW (self_frame),
+ &root, &child, &root_x, &root_y, &win_x, &win_y,
+ &mask))
+ {
+ ie.kind = DRAG_N_DROP_EVENT;
+ XSETFRAME (ie.frame_or_window, self_frame);
+
+ lval = Qnil;
+ atom_names = alloca (x_dnd_n_targets * sizeof *atom_names);
+ name = XGetAtomName (dpyinfo->display, x_dnd_wanted_action);
+
+ if (!XGetAtomNames (dpyinfo->display, x_dnd_targets,
+ x_dnd_n_targets, atom_names))
+ {
+ XFree (name);
+ return false;
+ }
+
+ for (i = x_dnd_n_targets; i != 0; --i)
+ {
+ lval = Fcons (intern (atom_names[i - 1]), lval);
+ XFree (atom_names[i - 1]);
+ }
+
+ lval = Fcons (intern (name), lval);
+ lval = Fcons (QXdndSelection, lval);
+ ie.arg = lval;
+ ie.timestamp = CurrentTime;
+
+ XSETINT (ie.x, win_x);
+ XSETINT (ie.y, win_y);
+
+ XFree (name);
+ kbd_buffer_store_event (&ie);
+
+ return false;
+ }
+ }
+ else if (x_dnd_action == None)
+ {
+ x_dnd_send_leave (f, target);
+ return false;
+ }
msg.xclient.type = ClientMessage;
msg.xclient.message_type = dpyinfo->Xatom_XdndDrop;
@@ -1068,7 +3504,10 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp,
if (supported >= 1)
msg.xclient.data.l[2] = timestamp;
- XSendEvent (FRAME_X_DISPLAY (f), target, False, 0, &msg);
+ x_catch_errors (dpyinfo->display);
+ XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
+ x_uncatch_errors ();
+ return true;
}
void
@@ -1081,119 +3520,80 @@ x_set_dnd_targets (Atom *targets, int ntargets)
x_dnd_n_targets = ntargets;
}
-Lisp_Object
-x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction,
- bool return_frame_p)
+static void
+x_dnd_cleanup_drag_and_drop (void *frame)
{
-#ifndef USE_GTK
- XEvent next_event;
- int finish;
-#endif
- struct input_event hold_quit;
- char *atom_name;
- Lisp_Object action, ltimestamp;
+ struct frame *f = frame;
+ xm_drop_start_message dmsg;
- if (!FRAME_VISIBLE_P (f))
- error ("Frame is invisible");
+ if (!x_dnd_unwind_flag)
+ return;
if (x_dnd_in_progress)
- error ("A drag-and-drop session is already in progress");
-
- ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f),
- QXdndSelection);
-
- if (NILP (ltimestamp))
- error ("No local value for XdndSelection");
-
- if (BIGNUMP (ltimestamp))
- x_dnd_selection_timestamp = bignum_to_intmax (ltimestamp);
- else
- x_dnd_selection_timestamp = XFIXNUM (ltimestamp);
-
- x_dnd_in_progress = true;
- x_dnd_frame = f;
- x_dnd_last_seen_window = FRAME_X_WINDOW (f);
- x_dnd_last_protocol_version = -1;
- x_dnd_mouse_rect_target = None;
- x_dnd_action = None;
- x_dnd_wanted_action = xaction;
- x_dnd_return_frame = 0;
-
- if (return_frame_p)
- x_dnd_return_frame = 1;
-
-#ifdef USE_GTK
- current_count = 0;
-#endif
-
- while (x_dnd_in_progress)
{
- hold_quit.kind = NO_EVENT;
-#ifdef USE_GTK
- current_finish = X_EVENT_NORMAL;
- current_hold_quit = &hold_quit;
-#endif
+ eassert (x_dnd_frame);
block_input ();
-#ifndef USE_GTK
- XNextEvent (FRAME_X_DISPLAY (f), &next_event);
-
- handle_one_xevent (FRAME_DISPLAY_INFO (f),
- &next_event, &finish, &hold_quit);
-#else
- gtk_main_iteration ();
-#endif
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1)
+ x_dnd_send_leave (x_dnd_frame,
+ x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style)
+ && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE
+ && x_dnd_motif_setup_p)
+ {
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DROP_START);
+ dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.timestamp = FRAME_DISPLAY_INFO (f)->last_user_time;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f),
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (FRAME_DISPLAY_INFO (f),
+ x_dnd_wanted_action),
+ XM_DROP_ACTION_DROP_CANCEL);
+ dmsg.x = 0;
+ dmsg.y = 0;
+ dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection;
+ dmsg.source_window = FRAME_X_WINDOW (f);
+
+ x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f,
+ x_dnd_last_seen_window,
+ FRAME_DISPLAY_INFO (f)->last_user_time);
+ xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f),
+ x_dnd_last_seen_window, &dmsg);
+ }
unblock_input ();
- if (hold_quit.kind != NO_EVENT)
- {
- if (x_dnd_in_progress)
- {
- block_input ();
- if (x_dnd_last_seen_window != None
- && x_dnd_last_protocol_version != -1)
- x_dnd_send_leave (f, x_dnd_last_seen_window);
- unblock_input ();
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_in_progress = false;
+ }
- x_dnd_in_progress = false;
- x_dnd_frame = NULL;
- }
+ x_set_dnd_targets (NULL, 0);
+ x_dnd_waiting_for_finish = false;
- FRAME_DISPLAY_INFO (f)->grabbed = 0;
-#ifdef USE_GTK
- current_hold_quit = NULL;
-#endif
- quit ();
- }
- }
+ if (x_dnd_use_toplevels)
+ x_dnd_free_toplevels ();
+ FRAME_DISPLAY_INFO (f)->grabbed = 0;
#ifdef USE_GTK
current_hold_quit = NULL;
#endif
+ x_dnd_return_frame_object = NULL;
+ x_dnd_movement_frame = NULL;
- if (x_dnd_return_frame == 3)
- {
- x_dnd_return_frame_object->mouse_moved = true;
-
- XSETFRAME (action, x_dnd_return_frame_object);
- return action;
- }
-
- FRAME_DISPLAY_INFO (f)->grabbed = 0;
-
- if (x_dnd_wanted_action != None)
- {
- block_input ();
- atom_name = XGetAtomName (FRAME_X_DISPLAY (f),
- x_dnd_wanted_action);
- action = intern (atom_name);
- XFree (atom_name);
- unblock_input ();
-
- return action;
- }
+ block_input ();
+ /* Restore the old event mask. */
+ XSelectInput (FRAME_X_DISPLAY (f),
+ FRAME_DISPLAY_INFO (f)->root_window,
+ x_dnd_old_window_attrs.your_event_mask);
+ unblock_input ();
- return Qnil;
+ x_dnd_frame = NULL;
}
/* Flush display of frame F. */
@@ -1443,6 +3843,77 @@ x_free_xi_devices (struct x_display_info *dpyinfo)
unblock_input ();
}
+static void
+xi_populate_device_from_info (struct xi_device_t *xi_device,
+ XIDeviceInfo *device)
+{
+#ifdef HAVE_XINPUT2_1
+ struct xi_scroll_valuator_t *valuator;
+ int actual_valuator_count;
+ XIScrollClassInfo *info;
+#endif
+#ifdef HAVE_XINPUT2_2
+ XITouchClassInfo *touch_info;
+#endif
+ int c;
+
+ xi_device->device_id = device->deviceid;
+ xi_device->grab = 0;
+
+#ifdef HAVE_XINPUT2_1
+ actual_valuator_count = 0;
+ xi_device->valuators =
+ xmalloc (sizeof *xi_device->valuators * device->num_classes);
+#endif
+#ifdef HAVE_XINPUT2_2
+ xi_device->touchpoints = NULL;
+#endif
+
+ xi_device->master_p = (device->use == XIMasterKeyboard
+ || device->use == XIMasterPointer);
+#ifdef HAVE_XINPUT2_2
+ xi_device->direct_p = false;
+#endif
+ xi_device->name = build_string (device->name);
+
+ for (c = 0; c < device->num_classes; ++c)
+ {
+ switch (device->classes[c]->type)
+ {
+#ifdef HAVE_XINPUT2_1
+ case XIScrollClass:
+ {
+ info = (XIScrollClassInfo *) device->classes[c];
+
+ valuator = &xi_device->valuators[actual_valuator_count++];
+ valuator->horizontal
+ = (info->scroll_type == XIScrollTypeHorizontal);
+ valuator->invalid_p = true;
+ valuator->emacs_value = DBL_MIN;
+ valuator->increment = info->increment;
+ valuator->number = info->number;
+ valuator->pending_enter_reset = false;
+
+ break;
+ }
+#endif
+#ifdef HAVE_XINPUT2_2
+ case XITouchClass:
+ {
+ touch_info = (XITouchClassInfo *) device->classes[c];
+ xi_device->direct_p = touch_info->mode == XIDirectTouch;
+ }
+#endif
+ default:
+ break;
+ }
+ }
+
+#ifdef HAVE_XINPUT2_1
+ xi_device->scroll_valuator_count = actual_valuator_count;
+#endif
+}
+
/* The code below handles the tracking of scroll valuators on XInput
2, in order to support scroll wheels that report information more
granular than a screen line.
@@ -1477,9 +3948,10 @@ x_free_xi_devices (struct x_display_info *dpyinfo)
static void
x_init_master_valuators (struct x_display_info *dpyinfo)
{
- int ndevices;
+ int ndevices, actual_devices;
XIDeviceInfo *infos;
+ actual_devices = 0;
block_input ();
x_free_xi_devices (dpyinfo);
infos = XIQueryDevice (dpyinfo->display,
@@ -1493,78 +3965,13 @@ x_init_master_valuators (struct x_display_info *dpyinfo)
return;
}
- int actual_devices = 0;
dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices);
for (int i = 0; i < ndevices; ++i)
{
- XIDeviceInfo *device = &infos[i];
-
- if (device->enabled)
- {
-#ifdef HAVE_XINPUT2_1
- int actual_valuator_count = 0;
-#endif
-
- struct xi_device_t *xi_device = &dpyinfo->devices[actual_devices++];
- xi_device->device_id = device->deviceid;
- xi_device->grab = 0;
-
-#ifdef HAVE_XINPUT2_1
- xi_device->valuators =
- xmalloc (sizeof *xi_device->valuators * device->num_classes);
-#endif
-#ifdef HAVE_XINPUT2_2
- xi_device->touchpoints = NULL;
-#endif
-
- xi_device->master_p = (device->use == XIMasterKeyboard
- || device->use == XIMasterPointer);
-#ifdef HAVE_XINPUT2_2
- xi_device->direct_p = false;
-#endif
-
- for (int c = 0; c < device->num_classes; ++c)
- {
- switch (device->classes[c]->type)
- {
-#ifdef HAVE_XINPUT2_1
- case XIScrollClass:
- {
- XIScrollClassInfo *info =
- (XIScrollClassInfo *) device->classes[c];
- struct xi_scroll_valuator_t *valuator;
-
- valuator = &xi_device->valuators[actual_valuator_count++];
- valuator->horizontal
- = (info->scroll_type == XIScrollTypeHorizontal);
- valuator->invalid_p = true;
- valuator->emacs_value = DBL_MIN;
- valuator->increment = info->increment;
- valuator->number = info->number;
- valuator->pending_enter_reset = false;
-
- break;
- }
-#endif
-#ifdef HAVE_XINPUT2_2
- case XITouchClass:
- {
- XITouchClassInfo *info;
-
- info = (XITouchClassInfo *) device->classes[c];
- xi_device->direct_p = info->mode == XIDirectTouch;
- }
-#endif
- default:
- break;
- }
- }
-
-#ifdef HAVE_XINPUT2_1
- xi_device->scroll_valuator_count = actual_valuator_count;
-#endif
- }
+ if (infos[i].enabled)
+ xi_populate_device_from_info (&dpyinfo->devices[actual_devices++],
+ &infos[i]);
}
dpyinfo->num_devices = actual_devices;
@@ -1574,58 +3981,49 @@ x_init_master_valuators (struct x_display_info *dpyinfo)
#ifdef HAVE_XINPUT2_1
/* Return the delta of the scroll valuator VALUATOR_NUMBER under
- DEVICE_ID in the display DPYINFO with VALUE. The valuator's
- valuator will be set to VALUE afterwards. In case no scroll
- valuator is found, or if the valuator state is invalid (see the
- comment under XI_Enter in handle_one_xevent), or if device_id is
- not known to Emacs, DBL_MAX is returned. Otherwise, the valuator
- is returned in VALUATOR_RETURN. */
+ DEVICE in the display DPYINFO with VALUE. The valuator's valuator
+ will be set to VALUE afterwards. In case no scroll valuator is
+ found, or if the valuator state is invalid (see the comment under
+ XI_Enter in handle_one_xevent). Otherwise, the valuator is
+ returned in VALUATOR_RETURN. */
static double
-x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id,
+x_get_scroll_valuator_delta (struct x_display_info *dpyinfo,
+ struct xi_device_t *device,
int valuator_number, double value,
struct xi_scroll_valuator_t **valuator_return)
{
- block_input ();
+ struct xi_scroll_valuator_t *sv;
+ double delta;
+ int i;
- for (int i = 0; i < dpyinfo->num_devices; ++i)
+ for (i = 0; i < device->scroll_valuator_count; ++i)
{
- struct xi_device_t *device = &dpyinfo->devices[i];
+ sv = &device->valuators[i];
- if (device->device_id == device_id)
+ if (sv->number == valuator_number)
{
- for (int j = 0; j < device->scroll_valuator_count; ++j)
- {
- struct xi_scroll_valuator_t *sv = &device->valuators[j];
+ *valuator_return = sv;
- if (sv->number == valuator_number)
- {
- if (sv->invalid_p)
- {
- sv->current_value = value;
- sv->invalid_p = false;
- *valuator_return = sv;
+ if (sv->increment == 0)
+ return DBL_MAX;
- unblock_input ();
- return DBL_MAX;
- }
- else
- {
- double delta = (sv->current_value - value) / sv->increment;
- sv->current_value = value;
- *valuator_return = sv;
+ if (sv->invalid_p)
+ {
+ sv->current_value = value;
+ sv->invalid_p = false;
- unblock_input ();
- return delta;
- }
- }
+ return DBL_MAX;
}
+ else
+ {
+ delta = (sv->current_value - value) / sv->increment;
+ sv->current_value = value;
- unblock_input ();
- return DBL_MAX;
+ return delta;
+ }
}
}
- unblock_input ();
return DBL_MAX;
}
@@ -1840,8 +4238,11 @@ x_set_cr_source_with_gc_foreground (struct frame *f, GC gc,
cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_SOURCE);
}
else
- cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0,
- color.green / 65535.0, color.blue / 65535.0);
+ {
+ cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0,
+ color.green / 65535.0, color.blue / 65535.0);
+ cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_OVER);
+ }
}
void
@@ -1869,8 +4270,11 @@ x_set_cr_source_with_gc_background (struct frame *f, GC gc,
cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_SOURCE);
}
else
- cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0,
- color.green / 65535.0, color.blue / 65535.0);
+ {
+ cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0,
+ color.green / 65535.0, color.blue / 65535.0);
+ cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_OVER);
+ }
}
static const cairo_user_data_key_t xlib_surface_key, saved_drawable_key;
@@ -2265,6 +4669,68 @@ x_reset_clip_rectangles (struct frame *f, GC gc)
#endif
}
+#ifdef HAVE_XRENDER
+# if !defined USE_CAIRO && (RENDER_MAJOR > 0 || RENDER_MINOR >= 2)
+static void
+x_xrender_color_from_gc_foreground (struct frame *f, GC gc, XRenderColor *color,
+ bool apply_alpha_background)
+{
+ XGCValues xgcv;
+ XColor xc;
+
+ XGetGCValues (FRAME_X_DISPLAY (f), gc, GCForeground, &xgcv);
+ xc.pixel = xgcv.foreground;
+ x_query_colors (f, &xc, 1);
+
+ color->alpha = (apply_alpha_background
+ ? 65535 * f->alpha_background
+ : 65535);
+
+ if (color->alpha == 65535)
+ {
+ color->red = xc.red;
+ color->blue = xc.blue;
+ color->green = xc.green;
+ }
+ else
+ {
+ color->red = (xc.red * color->alpha) / 65535;
+ color->blue = (xc.blue * color->alpha) / 65535;
+ color->green = (xc.green * color->alpha) / 65535;
+ }
+}
+# endif
+
+void
+x_xrender_color_from_gc_background (struct frame *f, GC gc, XRenderColor *color,
+ bool apply_alpha_background)
+{
+ XGCValues xgcv;
+ XColor xc;
+
+ XGetGCValues (FRAME_X_DISPLAY (f), gc, GCBackground, &xgcv);
+ xc.pixel = xgcv.background;
+ x_query_colors (f, &xc, 1);
+
+ color->alpha = (apply_alpha_background
+ ? 65535 * f->alpha_background
+ : 65535);
+
+ if (color->alpha == 65535)
+ {
+ color->red = xc.red;
+ color->blue = xc.blue;
+ color->green = xc.green;
+ }
+ else
+ {
+ color->red = (xc.red * color->alpha) / 65535;
+ color->blue = (xc.blue * color->alpha) / 65535;
+ color->green = (xc.green * color->alpha) / 65535;
+ }
+}
+#endif
+
static void
x_fill_rectangle (struct frame *f, GC gc, int x, int y, int width, int height,
bool respect_alpha_background)
@@ -2654,7 +5120,7 @@ x_set_frame_alpha (struct frame *f)
/* return unless necessary */
{
- unsigned char *data;
+ unsigned char *data = NULL;
Atom actual;
int rc, format;
unsigned long n, left;
@@ -2664,16 +5130,19 @@ x_set_frame_alpha (struct frame *f)
&actual, &format, &n, &left,
&data);
- if (rc == Success && actual != None)
+ if (rc == Success && actual != None && data)
{
- unsigned long value = *(unsigned long *)data;
- XFree (data);
+ unsigned long value = *(unsigned long *) data;
if (value == opac)
{
x_uncatch_errors ();
+ XFree (data);
return;
}
}
+
+ if (data)
+ XFree (data);
}
XChangeProperty (dpy, win, dpyinfo->Xatom_net_wm_window_opacity,
@@ -3225,7 +5694,7 @@ static void x_scroll_bar_clear (struct frame *);
static void x_check_font (struct frame *, struct font *);
#endif
-void
+static void
x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time)
{
#ifndef USE_GTK
@@ -6870,10 +9339,391 @@ x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc)
#else /* !USE_X_TOOLKIT && !USE_GTK */
#define x_any_window_to_frame(d, i) x_window_to_frame (d, i)
-#define x_top_window_to_frame(d, i) x_window_to_frame (d, i)
+
+struct frame *
+x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc)
+{
+ return x_window_to_frame (dpyinfo, wdesc);
+}
#endif /* USE_X_TOOLKIT || USE_GTK */
+/* This function is defined far away from the rest of the XDND code so
+ it can utilize `x_any_window_to_frame'. */
+
+Lisp_Object
+x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction,
+ Lisp_Object return_frame, Atom *ask_action_list,
+ const char **ask_action_names, size_t n_ask_actions,
+ bool allow_current_frame)
+{
+#ifndef USE_GTK
+ XEvent next_event;
+ int finish;
+#endif
+ XWindowAttributes root_window_attrs;
+ struct input_event hold_quit;
+ struct frame *any;
+ char *atom_name, *ask_actions;
+ Lisp_Object action, ltimestamp;
+ specpdl_ref ref;
+ ptrdiff_t i, end, fill;
+ XTextProperty prop;
+ xm_drop_start_message dmsg;
+ Lisp_Object frame_object, x, y, frame, local_value;
+
+ if (!FRAME_VISIBLE_P (f))
+ {
+ x_set_dnd_targets (NULL, 0);
+ error ("Frame is invisible");
+ }
+
+ XSETFRAME (frame, f);
+ local_value = assq_no_quit (QXdndSelection,
+ FRAME_TERMINAL (f)->Vselection_alist);
+
+ if (x_dnd_in_progress || x_dnd_waiting_for_finish)
+ {
+ x_set_dnd_targets (NULL, 0);
+ error ("A drag-and-drop session is already in progress");
+ }
+
+ if (CONSP (local_value))
+ x_own_selection (QXdndSelection,
+ Fnth (make_fixnum (1), local_value), frame);
+ else
+ {
+ x_set_dnd_targets (NULL, 0);
+ error ("No local value for XdndSelection");
+ }
+
+ if (popup_activated ())
+ {
+ x_set_dnd_targets (NULL, 0);
+ error ("Trying to drag-and-drop from within a menu-entry");
+ }
+
+ ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f),
+ QXdndSelection);
+
+ if (BIGNUMP (ltimestamp))
+ x_dnd_selection_timestamp = bignum_to_intmax (ltimestamp);
+ else
+ x_dnd_selection_timestamp = XFIXNUM (ltimestamp);
+
+ if (n_ask_actions)
+ {
+ ask_actions = NULL;
+ end = 0;
+
+ for (i = 0; i < n_ask_actions; ++i)
+ {
+ fill = end;
+ end += strlen (ask_action_names[i]) + 1;
+
+ if (ask_actions)
+ ask_actions = xrealloc (ask_actions, end);
+ else
+ ask_actions = xmalloc (end);
+
+ strncpy (ask_actions + fill,
+ ask_action_names[i],
+ end - fill);
+ }
+
+ prop.value = (unsigned char *) ask_actions;
+ prop.encoding = XA_STRING;
+ prop.format = 8;
+ prop.nitems = end;
+
+ block_input ();
+ XSetTextProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ &prop, FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription);
+ xfree (ask_actions);
+
+ XChangeProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList, XA_ATOM, 32,
+ PropModeReplace, (unsigned char *) ask_action_list,
+ n_ask_actions);
+ unblock_input ();
+ }
+ else
+ {
+ /* Delete those two properties, since some clients look at them
+ and not the action to decide whether or not the user should
+ be prompted to select an action. */
+
+ block_input ();
+ XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList);
+ XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription);
+ unblock_input ();
+ }
+
+ x_dnd_in_progress = true;
+ x_dnd_frame = f;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_last_protocol_version = -1;
+ x_dnd_last_motif_style = XM_DRAG_STYLE_NONE;
+ x_dnd_mouse_rect_target = None;
+ x_dnd_action = None;
+ x_dnd_wanted_action = xaction;
+ x_dnd_return_frame = 0;
+ x_dnd_waiting_for_finish = false;
+ x_dnd_waiting_for_motif_finish = 0;
+ x_dnd_xm_use_help = false;
+ x_dnd_motif_setup_p = false;
+ x_dnd_end_window = None;
+ x_dnd_use_toplevels
+ = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking);
+ x_dnd_toplevels = NULL;
+ x_dnd_allow_current_frame = allow_current_frame;
+ x_dnd_movement_frame = NULL;
+
+ if (x_dnd_use_toplevels)
+ {
+ if (x_dnd_compute_toplevels (FRAME_DISPLAY_INFO (f)))
+ {
+ x_dnd_free_toplevels ();
+ x_dnd_use_toplevels = false;
+ }
+ }
+
+ if (!NILP (return_frame))
+ x_dnd_return_frame = 1;
+
+ if (EQ (return_frame, Qnow))
+ x_dnd_return_frame = 2;
+
+#ifdef USE_GTK
+ current_count = 0;
+#endif
+
+ /* Now select for SubstructureNotifyMask and PropertyNotifyMask on
+ the root window, so we can get notified when window stacking
+ changes, a common operation during drag-and-drop. */
+
+ block_input ();
+ XGetWindowAttributes (FRAME_X_DISPLAY (f),
+ FRAME_DISPLAY_INFO (f)->root_window,
+ &root_window_attrs);
+
+ XSelectInput (FRAME_X_DISPLAY (f),
+ FRAME_DISPLAY_INFO (f)->root_window,
+ root_window_attrs.your_event_mask
+ | SubstructureNotifyMask
+ | PropertyChangeMask);
+
+ if (EQ (return_frame, Qnow))
+ x_dnd_update_state (FRAME_DISPLAY_INFO (f), CurrentTime);
+
+ while (x_dnd_in_progress || x_dnd_waiting_for_finish)
+ {
+ hold_quit.kind = NO_EVENT;
+#ifdef USE_GTK
+ current_finish = X_EVENT_NORMAL;
+ current_hold_quit = &hold_quit;
+#endif
+
+#ifdef USE_GTK
+ gtk_main_iteration ();
+#else
+#ifdef USE_X_TOOLKIT
+ XtAppNextEvent (Xt_app_con, &next_event);
+#else
+ XNextEvent (FRAME_X_DISPLAY (f), &next_event);
+#endif
+
+#ifdef HAVE_X_I18N
+#ifdef HAVE_XINPUT2
+ if (next_event.type != GenericEvent
+ || !FRAME_DISPLAY_INFO (f)->supports_xi2
+ || (next_event.xgeneric.extension
+ != FRAME_DISPLAY_INFO (f)->xi2_opcode))
+ {
+#endif
+ if (!x_filter_event (FRAME_DISPLAY_INFO (f), &next_event))
+ handle_one_xevent (FRAME_DISPLAY_INFO (f),
+ &next_event, &finish, &hold_quit);
+#ifdef HAVE_XINPUT2
+ }
+ else
+ handle_one_xevent (FRAME_DISPLAY_INFO (f),
+ &next_event, &finish, &hold_quit);
+#endif
+#else
+ handle_one_xevent (FRAME_DISPLAY_INFO (f),
+ &next_event, &finish, &hold_quit);
+#endif
+#endif
+
+ if (x_dnd_movement_frame)
+ {
+ XSETFRAME (frame_object, x_dnd_movement_frame);
+ XSETINT (x, x_dnd_movement_x);
+ XSETINT (y, x_dnd_movement_y);
+ x_dnd_movement_frame = NULL;
+
+ if (!NILP (Vx_dnd_movement_function)
+ && !FRAME_TOOLTIP_P (XFRAME (frame_object))
+ && x_dnd_movement_x >= 0
+ && x_dnd_movement_y >= 0
+ && x_dnd_frame
+ && (XFRAME (frame_object) != x_dnd_frame
+ || x_dnd_allow_current_frame))
+ {
+ x_dnd_old_window_attrs = root_window_attrs;
+ x_dnd_unwind_flag = true;
+
+ ref = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f);
+ call2 (Vx_dnd_movement_function, frame_object,
+ Fposn_at_x_y (x, y, frame_object, Qnil));
+ x_dnd_unwind_flag = false;
+ unbind_to (ref, Qnil);
+ }
+ }
+
+ if (hold_quit.kind != NO_EVENT)
+ {
+ if (hold_quit.kind == SELECTION_REQUEST_EVENT)
+ {
+ x_dnd_old_window_attrs = root_window_attrs;
+ x_dnd_unwind_flag = true;
+
+ ref = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f);
+ x_handle_selection_event ((struct selection_input_event *) &hold_quit);
+ x_dnd_unwind_flag = false;
+ unbind_to (ref, Qnil);
+ continue;
+ }
+
+ if (x_dnd_in_progress)
+ {
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1)
+ x_dnd_send_leave (f, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style)
+ && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE
+ && x_dnd_motif_setup_p)
+ {
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DROP_START);
+ dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.timestamp = hold_quit.timestamp;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f),
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (FRAME_DISPLAY_INFO (f),
+ x_dnd_wanted_action),
+ XM_DROP_ACTION_DROP_CANCEL);
+ dmsg.x = 0;
+ dmsg.y = 0;
+ dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection;
+ dmsg.source_window = FRAME_X_WINDOW (f);
+
+ x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f,
+ x_dnd_last_seen_window,
+ hold_quit.timestamp);
+ xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f),
+ x_dnd_last_seen_window, &dmsg);
+ }
+
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_in_progress = false;
+ x_dnd_frame = NULL;
+ }
+
+ x_set_dnd_targets (NULL, 0);
+ x_dnd_waiting_for_finish = false;
+
+ if (x_dnd_use_toplevels)
+ x_dnd_free_toplevels ();
+
+ x_dnd_return_frame_object = NULL;
+ x_dnd_movement_frame = NULL;
+
+ FRAME_DISPLAY_INFO (f)->grabbed = 0;
+#ifdef USE_GTK
+ current_hold_quit = NULL;
+#endif
+ /* Restore the old event mask. */
+ XSelectInput (FRAME_X_DISPLAY (f),
+ FRAME_DISPLAY_INFO (f)->root_window,
+ root_window_attrs.your_event_mask);
+ unblock_input ();
+ quit ();
+ }
+ }
+
+ x_set_dnd_targets (NULL, 0);
+ x_dnd_waiting_for_finish = false;
+
+#ifdef USE_GTK
+ current_hold_quit = NULL;
+#endif
+ x_dnd_movement_frame = NULL;
+
+ /* Restore the old event mask. */
+ XSelectInput (FRAME_X_DISPLAY (f),
+ FRAME_DISPLAY_INFO (f)->root_window,
+ root_window_attrs.your_event_mask);
+
+ unblock_input ();
+
+ if (x_dnd_return_frame == 3
+ && FRAME_LIVE_P (x_dnd_return_frame_object))
+ {
+ /* Deliberately preserve the last device if
+ x_dnd_return_frame_object is the drag source. */
+
+ if (x_dnd_return_frame_object != x_dnd_frame)
+ x_dnd_return_frame_object->last_mouse_device = Qnil;
+
+ x_dnd_return_frame_object->mouse_moved = true;
+
+ XSETFRAME (action, x_dnd_return_frame_object);
+ x_dnd_return_frame_object = NULL;
+ return action;
+ }
+
+ x_dnd_return_frame_object = NULL;
+
+ if (x_dnd_use_toplevels)
+ x_dnd_free_toplevels ();
+ FRAME_DISPLAY_INFO (f)->grabbed = 0;
+
+ /* Emacs can't respond to DND events inside the nested event
+ loop, so when dragging items to itself, always return
+ XdndActionPrivate. */
+ if (x_dnd_end_window != None
+ && (any = x_any_window_to_frame (FRAME_DISPLAY_INFO (f),
+ x_dnd_end_window))
+ && (allow_current_frame || any != f))
+ return QXdndActionPrivate;
+
+ if (x_dnd_action != None)
+ {
+ block_input ();
+ atom_name = XGetAtomName (FRAME_X_DISPLAY (f),
+ x_dnd_action);
+ action = intern (atom_name);
+ XFree (atom_name);
+ unblock_input ();
+
+ return action;
+ }
+
+ return Qnil;
+}
+
/* The focus may have changed. Figure out if it is a real focus change,
by checking both FocusIn/Out and Enter/LeaveNotify events.
@@ -7033,6 +9883,7 @@ x_find_modifier_meanings (struct x_display_info *dpyinfo)
#ifdef HAVE_XKB
int i;
int found_meta_p = false;
+ uint vmodmask;
#endif
dpyinfo->meta_mod_mask = 0;
@@ -7047,12 +9898,14 @@ x_find_modifier_meanings (struct x_display_info *dpyinfo)
{
for (i = 0; i < XkbNumVirtualMods; i++)
{
- uint vmodmask = dpyinfo->xkb_desc->server->vmods[i];
+ vmodmask = dpyinfo->xkb_desc->server->vmods[i];
if (dpyinfo->xkb_desc->names->vmods[i] == dpyinfo->Xatom_Meta)
{
dpyinfo->meta_mod_mask |= vmodmask;
- found_meta_p = vmodmask;
+
+ if (vmodmask)
+ found_meta_p = true;
}
else if (dpyinfo->xkb_desc->names->vmods[i] == dpyinfo->Xatom_Alt)
dpyinfo->alt_mod_mask |= vmodmask;
@@ -7354,7 +10207,8 @@ x_construct_mouse_click (struct input_event *result,
XI_Enter and XI_Leave labels inside `handle_one_xevent'. */
static bool
-x_note_mouse_movement (struct frame *frame, const XMotionEvent *event)
+x_note_mouse_movement (struct frame *frame, const XMotionEvent *event,
+ Lisp_Object device)
{
XRectangle *r;
struct x_display_info *dpyinfo;
@@ -7371,6 +10225,7 @@ x_note_mouse_movement (struct frame *frame, const XMotionEvent *event)
if (event->window != FRAME_X_WINDOW (frame))
{
frame->mouse_moved = true;
+ frame->last_mouse_device = device;
dpyinfo->last_mouse_scroll_bar = NULL;
note_mouse_highlight (frame, -1, -1);
dpyinfo->last_mouse_glyph_frame = NULL;
@@ -7385,6 +10240,7 @@ x_note_mouse_movement (struct frame *frame, const XMotionEvent *event)
|| event->y < r->y || event->y >= r->y + r->height)
{
frame->mouse_moved = true;
+ frame->last_mouse_device = device;
dpyinfo->last_mouse_scroll_bar = NULL;
note_mouse_highlight (frame, event->x, event->y);
/* Remember which glyph we're now on. */
@@ -7487,7 +10343,8 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
x_catch_errors (FRAME_X_DISPLAY (*fp));
- if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping))
+ if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping)
+ && !EQ (track_mouse, Qdrag_source))
{
/* If mouse was grabbed on a frame, give coords for that frame
even if the mouse is now outside it. */
@@ -7576,7 +10433,8 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
}
if ((!f1 || FRAME_TOOLTIP_P (f1))
- && EQ (track_mouse, Qdropping)
+ && (EQ (track_mouse, Qdropping)
+ || EQ (track_mouse, Qdrag_source))
&& gui_mouse_grabbed (dpyinfo))
{
/* When dropping then if we didn't get a frame or only a
@@ -7592,12 +10450,28 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
root_x, root_y, &win_x, &win_y,
/* Child of win. */
&child);
- f1 = dpyinfo->last_mouse_frame;
+
+ if (!EQ (track_mouse, Qdrag_source)
+ /* Don't let tooltips interfere. */
+ || (f1 && FRAME_TOOLTIP_P (f1)))
+ f1 = dpyinfo->last_mouse_frame;
+ else
+ {
+ /* Don't set FP but do set WIN_X and WIN_Y in this
+ case, so make_lispy_movement knows which
+ coordinates to report. */
+ *bar_window = Qnil;
+ *part = 0;
+ *fp = NULL;
+ XSETINT (*x, win_x);
+ XSETINT (*y, win_y);
+ *timestamp = dpyinfo->last_mouse_movement_time;
+ }
}
else if (f1 && FRAME_TOOLTIP_P (f1))
f1 = NULL;
- if (x_had_errors_p (FRAME_X_DISPLAY (*fp)))
+ if (x_had_errors_p (dpyinfo->display))
f1 = NULL;
x_uncatch_errors_after_check ();
@@ -7607,7 +10481,7 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
{
struct scroll_bar *bar;
- bar = x_window_to_scroll_bar (FRAME_X_DISPLAY (*fp), win, 2);
+ bar = x_window_to_scroll_bar (dpyinfo->display, win, 2);
if (bar)
{
@@ -7894,7 +10768,8 @@ x_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part,
/* Setting the event mask to zero means that the message will
be sent to the client that created the window, and if that
window no longer exists, no event will be sent. */
- XSendEvent (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), False, 0, &event);
+ XSendEvent (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), False,
+ NoEventMask, &event);
unblock_input ();
}
@@ -10411,7 +13286,8 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc)
? dpyinfo->last_mouse_frame
: NULL);
- if (lm_f && !EQ (track_mouse, Qdropping))
+ if (lm_f && !EQ (track_mouse, Qdropping)
+ && !EQ (track_mouse, Qdrag_source))
return lm_f;
else
{
@@ -10427,6 +13303,204 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc)
}
}
+/* Get the window underneath the pointer, see if it moved, and update
+ the DND state accordingly. */
+static void
+x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp)
+{
+ int root_x, root_y, dummy_x, dummy_y, target_proto, motif_style;
+ unsigned int dummy_mask;
+ Window dummy, dummy_child, target, toplevel;
+ xm_top_level_leave_message lmsg;
+ xm_top_level_enter_message emsg;
+ xm_drag_motion_message dmsg;
+ xm_drop_start_message dsmsg;
+
+ if (XQueryPointer (dpyinfo->display,
+ dpyinfo->root_window,
+ &dummy, &dummy_child,
+ &root_x, &root_y,
+ &dummy_x, &dummy_y,
+ &dummy_mask))
+ {
+ target = x_dnd_get_target_window (dpyinfo, root_x,
+ root_y, &target_proto,
+ &motif_style, &toplevel);
+
+ if (toplevel != x_dnd_last_seen_toplevel)
+ {
+ if (toplevel != FRAME_OUTER_WINDOW (x_dnd_frame)
+ && x_dnd_return_frame == 1)
+ x_dnd_return_frame = 2;
+
+ if (x_dnd_return_frame == 2
+ && x_any_window_to_frame (dpyinfo, toplevel))
+ {
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = timestamp;
+ lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &lmsg);
+ }
+
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_in_progress = false;
+ x_dnd_return_frame_object
+ = x_any_window_to_frame (dpyinfo, toplevel);
+ x_dnd_return_frame = 3;
+ x_dnd_waiting_for_finish = false;
+ target = None;
+ }
+
+ x_dnd_last_seen_toplevel = toplevel;
+ }
+
+ if (target != x_dnd_last_seen_window)
+ {
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = timestamp;
+ lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &lmsg);
+ }
+
+ x_dnd_action = None;
+ x_dnd_last_seen_window = target;
+ x_dnd_last_protocol_version = target_proto;
+ x_dnd_last_motif_style = motif_style;
+
+ if (target != None && x_dnd_last_protocol_version != -1)
+ x_dnd_send_enter (x_dnd_frame, target,
+ x_dnd_last_protocol_version);
+ else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_ENTER);
+ emsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ emsg.zero = 0;
+ emsg.timestamp = timestamp;
+ emsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+ emsg.index_atom = dpyinfo->Xatom_XdndSelection;
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ target, &emsg);
+ }
+ }
+
+ if (x_dnd_last_protocol_version != -1 && target != None)
+ x_dnd_send_position (x_dnd_frame, target,
+ x_dnd_last_protocol_version,
+ root_x, root_y,
+ x_dnd_selection_timestamp,
+ x_dnd_wanted_action);
+ else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None)
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DRAG_MOTION);
+ dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ (!x_dnd_xm_use_help
+ ? XM_DROP_ACTION_DROP
+ : XM_DROP_ACTION_DROP_HELP));
+ dmsg.timestamp = timestamp;
+ dmsg.x = root_x;
+ dmsg.y = root_y;
+
+ if (x_dnd_motif_setup_p)
+ xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ target, &dmsg);
+ }
+ }
+ /* The pointer moved out of the screen. */
+ else if (x_dnd_last_protocol_version != -1)
+ {
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1)
+ x_dnd_send_leave (x_dnd_frame,
+ x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style)
+ && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE
+ && x_dnd_motif_setup_p)
+ {
+ dsmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DROP_START);
+ dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ dsmsg.timestamp = timestamp;
+ dsmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_ACTION_DROP_CANCEL);
+ dsmsg.x = 0;
+ dsmsg.y = 0;
+ dsmsg.index_atom
+ = FRAME_DISPLAY_INFO (x_dnd_frame)->Xatom_XdndSelection;
+ dsmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ x_dnd_send_xm_leave_for_drop (dpyinfo, x_dnd_frame,
+ x_dnd_last_seen_window, timestamp);
+ xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &dsmsg);
+ }
+
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_in_progress = false;
+ x_dnd_waiting_for_finish = false;
+ x_dnd_frame = NULL;
+ }
+}
+
/* Handles the XEvent EVENT on display DPYINFO.
*FINISH is X_EVENT_GOTO_OUT if caller should stop reading events.
@@ -10526,12 +13600,84 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (event->xclient.data.l[1] & 1)
{
if (x_dnd_last_protocol_version >= 2)
- x_dnd_wanted_action = event->xclient.data.l[4];
+ x_dnd_action = event->xclient.data.l[4];
else
- x_dnd_wanted_action = dpyinfo->Xatom_XdndActionCopy;
+ x_dnd_action = dpyinfo->Xatom_XdndActionCopy;
}
else
- x_dnd_wanted_action = None;
+ x_dnd_action = None;
+ }
+
+ goto done;
+ }
+
+ if (event->xclient.message_type == dpyinfo->Xatom_XdndFinished
+ && (x_dnd_waiting_for_finish && !x_dnd_waiting_for_motif_finish)
+ && event->xclient.data.l[0] == x_dnd_pending_finish_target)
+ {
+ x_dnd_waiting_for_finish = false;
+
+ if (x_dnd_waiting_for_finish_proto >= 5)
+ x_dnd_action = event->xclient.data.l[2];
+
+ if (x_dnd_waiting_for_finish_proto >= 5
+ && !(event->xclient.data.l[1] & 1))
+ x_dnd_action = None;
+
+ goto done;
+ }
+
+ if ((event->xclient.message_type
+ == dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE)
+ /* FIXME: There should probably be a check that the event
+ comes from the same display where the drop event was
+ sent, but there's no way to get that information here
+ safely. */
+ && x_dnd_waiting_for_finish
+ && x_dnd_waiting_for_motif_finish == 1)
+ {
+ xm_drop_start_reply reply;
+ uint16_t operation, status, action;
+
+ if (!xm_read_drop_start_reply (event, &reply))
+ {
+ operation = XM_DRAG_SIDE_EFFECT_OPERATION (reply.side_effects);
+ status = XM_DRAG_SIDE_EFFECT_SITE_STATUS (reply.side_effects);
+ action = XM_DRAG_SIDE_EFFECT_DROP_ACTION (reply.side_effects);
+
+ if (operation != XM_DRAG_MOVE
+ && operation != XM_DRAG_COPY
+ && operation != XM_DRAG_LINK)
+ {
+ x_dnd_waiting_for_finish = false;
+ goto done;
+ }
+
+ if (status != XM_DROP_SITE_VALID
+ || (action == XM_DROP_ACTION_DROP_CANCEL
+ || action == XM_DROP_ACTION_DROP_HELP))
+ {
+ x_dnd_waiting_for_finish = false;
+ goto done;
+ }
+
+ switch (operation)
+ {
+ case XM_DRAG_MOVE:
+ x_dnd_action = dpyinfo->Xatom_XdndActionMove;
+ break;
+
+ case XM_DRAG_COPY:
+ x_dnd_action = dpyinfo->Xatom_XdndActionCopy;
+ break;
+
+ case XM_DRAG_LINK:
+ x_dnd_action = dpyinfo->Xatom_XdndActionLink;
+ break;
+ }
+
+ x_dnd_waiting_for_motif_finish = 2;
+ goto done;
}
}
@@ -10633,7 +13779,19 @@ handle_one_xevent (struct x_display_info *dpyinfo,
send_event.xclient.window = dpyinfo->root_window;
XSendEvent (dpyinfo->display, dpyinfo->root_window, False,
- SubstructureRedirectMask | SubstructureNotifyMask,
+ /* FIXME: handling window stacking changes
+ during drag-and-drop requires Emacs to
+ select for SubstructureNotifyMask,
+ which in turn causes the message to be
+ sent to Emacs itself using the event
+ mask specified by the EWMH. To avoid
+ an infinite loop, just use
+ SubstructureRedirectMask when a
+ drag-and-drop operation is in
+ progress. */
+ ((x_dnd_in_progress || x_dnd_waiting_for_finish)
+ ? SubstructureRedirectMask
+ : SubstructureRedirectMask | SubstructureNotifyMask),
&send_event);
*finish = X_EVENT_DROP;
@@ -10819,10 +13977,88 @@ handle_one_xevent (struct x_display_info *dpyinfo,
SELECTION_EVENT_TARGET (&inev.sie) = eventp->target;
SELECTION_EVENT_PROPERTY (&inev.sie) = eventp->property;
SELECTION_EVENT_TIME (&inev.sie) = eventp->time;
+
+ /* If drag-and-drop is in progress, handle SelectionRequest
+ events immediately, by setting hold_quit to the input
+ event. */
+
+ if (x_dnd_in_progress || x_dnd_waiting_for_finish)
+ {
+ eassume (hold_quit);
+
+ *hold_quit = inev.ie;
+ EVENT_INIT (inev.ie);
+ }
+
+ if (x_dnd_waiting_for_finish
+ && x_dnd_waiting_for_motif_finish == 2
+ && eventp->selection == dpyinfo->Xatom_XdndSelection
+ && (eventp->target == dpyinfo->Xatom_XmTRANSFER_SUCCESS
+ || eventp->target == dpyinfo->Xatom_XmTRANSFER_FAILURE))
+ x_dnd_waiting_for_finish = false;
}
break;
case PropertyNotify:
+ if (x_dnd_in_progress && x_dnd_use_toplevels
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)
+ && event->xproperty.atom == dpyinfo->Xatom_wm_state)
+ {
+ struct x_client_list_window *tem, *last;
+
+ for (last = NULL, tem = x_dnd_toplevels; tem;
+ last = tem, tem = tem->next)
+ {
+ if (tem->window == event->xproperty.window)
+ {
+ Atom actual_type;
+ int actual_format, rc;
+ unsigned long nitems, bytesafter;
+ unsigned char *data = NULL;
+
+
+ if (event->xproperty.state == PropertyDelete)
+ {
+ if (!last)
+ x_dnd_toplevels = tem->next;
+ else
+ last->next = tem->next;
+
+#ifdef HAVE_XSHAPE
+ if (tem->n_input_rects != -1)
+ xfree (tem->input_rects);
+ if (tem->n_bounding_rects != -1)
+ xfree (tem->bounding_rects);
+#endif
+ xfree (tem);
+ }
+ else
+ {
+ x_catch_errors (dpyinfo->display);
+ rc = XGetWindowProperty (dpyinfo->display,
+ event->xproperty.window,
+ dpyinfo->Xatom_wm_state,
+ 0, 2, False, AnyPropertyType,
+ &actual_type, &actual_format,
+ &nitems, &bytesafter, &data);
+
+ if (!x_had_errors_p (dpyinfo->display) && rc == Success && data
+ && nitems == 2 && actual_format == 32)
+ tem->wm_state = ((unsigned long *) data)[0];
+ else
+ tem->wm_state = WithdrawnState;
+
+ if (data)
+ XFree (data);
+ x_uncatch_errors_after_check ();
+ }
+
+ x_dnd_update_state (dpyinfo, event->xproperty.time);
+ break;
+ }
+ }
+ }
+
f = x_top_window_to_frame (dpyinfo, event->xproperty.window);
if (f && event->xproperty.atom == dpyinfo->Xatom_net_wm_state)
{
@@ -10867,6 +14103,26 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
}
+ if (event->xproperty.window == dpyinfo->root_window
+ && (event->xproperty.atom == dpyinfo->Xatom_net_client_list_stacking
+ || event->xproperty.atom == dpyinfo->Xatom_net_current_desktop)
+ && x_dnd_in_progress
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
+ {
+ if (x_dnd_use_toplevels)
+ {
+ x_dnd_free_toplevels ();
+
+ if (x_dnd_compute_toplevels (dpyinfo))
+ {
+ x_dnd_free_toplevels ();
+ x_dnd_use_toplevels = false;
+ }
+ }
+
+ x_dnd_update_state (dpyinfo, event->xproperty.time);
+ }
+
x_handle_property_notify (&event->xproperty);
xft_settings_event (dpyinfo, event);
goto OTHER;
@@ -11036,6 +14292,20 @@ handle_one_xevent (struct x_display_info *dpyinfo,
break;
case UnmapNotify:
+ if (x_dnd_in_progress && x_dnd_use_toplevels
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
+ {
+ for (struct x_client_list_window *tem = x_dnd_toplevels; tem;
+ tem = tem->next)
+ {
+ if (tem->window == event->xunmap.window)
+ {
+ tem->mapped_p = false;
+ break;
+ }
+ }
+ }
+
/* Redo the mouse-highlight after the tooltip has gone. */
if (event->xunmap.window == tip_window)
{
@@ -11080,6 +14350,24 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (xg_is_menu_window (dpyinfo->display, event->xmap.window))
popup_activated_flag = 1;
#endif
+
+ if (x_dnd_in_progress)
+ x_dnd_update_state (dpyinfo, dpyinfo->last_user_time);
+
+ if (x_dnd_in_progress && x_dnd_use_toplevels
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
+ {
+ for (struct x_client_list_window *tem = x_dnd_toplevels; tem;
+ tem = tem->next)
+ {
+ if (tem->window == event->xmap.window)
+ {
+ tem->mapped_p = true;
+ break;
+ }
+ }
+ }
+
/* We use x_top_window_to_frame because map events can
come for sub-windows and they don't mean that the
frame is visible. */
@@ -11221,6 +14509,24 @@ handle_one_xevent (struct x_display_info *dpyinfo,
`event' itself. */
XKeyEvent xkey = event->xkey;
int i;
+#ifdef HAVE_XINPUT2
+ Time pending_keystroke_time;
+ struct xi_device_t *source;
+
+ pending_keystroke_time = dpyinfo->pending_keystroke_time;
+
+ if (event->xkey.time >= pending_keystroke_time)
+ {
+#if defined USE_GTK && !defined HAVE_GTK3
+ if (!dpyinfo->pending_keystroke_time_special_p)
+#endif
+ dpyinfo->pending_keystroke_time = 0;
+#if defined USE_GTK && !defined HAVE_GTK3
+ else
+ dpyinfo->pending_keystroke_time_special_p = false;
+#endif
+ }
+#endif
#ifdef USE_GTK
/* Don't pass keys to GTK. A Tab will shift focus to the
@@ -11314,6 +14620,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
&compose_status);
#endif
+#ifdef XK_F1
+ if (x_dnd_in_progress && keysym == XK_F1)
+ {
+ x_dnd_xm_use_help = true;
+ goto done_keysym;
+ }
+#endif
+
/* If not using XIM/XIC, and a compose sequence is in progress,
we break here. Otherwise, chars_matched is always 0. */
if (compose_status.chars_matched > 0 && nbytes == 0)
@@ -11335,6 +14649,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
inev.ie.kind = ASCII_KEYSTROKE_EVENT;
inev.ie.code = keysym;
+
+#ifdef HAVE_XINPUT2
+ if (event->xkey.time == pending_keystroke_time)
+ {
+ source = xi_device_from_id (dpyinfo,
+ dpyinfo->pending_keystroke_source);
+
+ if (source)
+ inev.ie.device = source->name;
+ }
+#endif
+
goto done_keysym;
}
@@ -11346,6 +14672,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
else
inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT;
inev.ie.code = keysym & 0xFFFFFF;
+
+#ifdef HAVE_XINPUT2
+ if (event->xkey.time == pending_keystroke_time)
+ {
+ source = xi_device_from_id (dpyinfo,
+ dpyinfo->pending_keystroke_source);
+
+ if (source)
+ inev.ie.device = source->name;
+ }
+#endif
+
goto done_keysym;
}
@@ -11360,6 +14698,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
? ASCII_KEYSTROKE_EVENT
: MULTIBYTE_CHAR_KEYSTROKE_EVENT);
inev.ie.code = XFIXNAT (c);
+
+#ifdef HAVE_XINPUT2
+ if (event->xkey.time == pending_keystroke_time)
+ {
+ source = xi_device_from_id (dpyinfo,
+ dpyinfo->pending_keystroke_source);
+
+ if (source)
+ inev.ie.device = source->name;
+ }
+#endif
+
goto done_keysym;
}
@@ -11464,6 +14814,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
key. */
inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
inev.ie.code = keysym;
+
+#ifdef HAVE_XINPUT2
+ if (event->xkey.time == pending_keystroke_time)
+ {
+ source = xi_device_from_id (dpyinfo,
+ dpyinfo->pending_keystroke_source);
+
+ if (source)
+ inev.ie.device = source->name;
+ }
+#endif
+
goto done_keysym;
}
@@ -11482,6 +14844,22 @@ handle_one_xevent (struct x_display_info *dpyinfo,
Fput_text_property (make_fixnum (0), make_fixnum (nbytes),
Qcoding, coding, inev.ie.arg);
+
+#ifdef HAVE_XINPUT2
+ if (event->xkey.time == pending_keystroke_time
+ /* I-Bus sometimes sends events generated from
+ multiple filtered keystrokes with a time of 0,
+ so just use the recorded source device if it
+ exists. */
+ || (pending_keystroke_time && !event->xkey.time))
+ {
+ source = xi_device_from_id (dpyinfo,
+ dpyinfo->pending_keystroke_source);
+
+ if (source)
+ inev.ie.device = source->name;
+ }
+#endif
}
if (keysym == NoSymbol)
@@ -11556,12 +14934,13 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* EnterNotify counts as mouse movement,
so update things that depend on mouse position. */
if (f && !f->output_data.x->hourglass_p)
- x_note_mouse_movement (f, &event->xmotion);
+ x_note_mouse_movement (f, &event->xmotion, Qnil);
#ifdef USE_GTK
/* We may get an EnterNotify on the buttons in the toolbar. In that
case we moved out of any highlighted area and need to note this. */
if (!f && dpyinfo->last_mouse_glyph_frame)
- x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &event->xmotion);
+ x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &event->xmotion,
+ Qnil);
#endif
goto OTHER;
@@ -11652,7 +15031,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifdef USE_GTK
/* See comment in EnterNotify above */
else if (dpyinfo->last_mouse_glyph_frame)
- x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &event->xmotion);
+ x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame,
+ &event->xmotion, Qnil);
#endif
goto OTHER;
@@ -11673,44 +15053,148 @@ handle_one_xevent (struct x_display_info *dpyinfo,
clear_mouse_face (hlinfo);
}
+ f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window);
+
if (x_dnd_in_progress
&& dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
{
- Window target;
- int target_proto;
+ Window target, toplevel;
+ int target_proto, motif_style;
+ xm_top_level_leave_message lmsg;
+ xm_top_level_enter_message emsg;
+ xm_drag_motion_message dmsg;
+
+ /* Sometimes the drag-and-drop operation starts with the
+ pointer of a frame invisible due to input. Since
+ motion events are ignored during that, make the pointer
+ visible manually. */
+
+ if (f)
+ XTtoggle_invisible_pointer (f, false);
target = x_dnd_get_target_window (dpyinfo,
event->xmotion.x_root,
event->xmotion.y_root,
- &target_proto);
+ &target_proto,
+ &motif_style, &toplevel);
- if (target != x_dnd_last_seen_window)
+ if (toplevel != x_dnd_last_seen_toplevel)
{
- if (x_dnd_last_seen_window != None
- && x_dnd_last_protocol_version != -1
- && x_dnd_last_seen_window != FRAME_X_WINDOW (x_dnd_frame))
- x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
-
- if (x_dnd_last_seen_window == FRAME_X_WINDOW (x_dnd_frame)
+ if (toplevel != FRAME_OUTER_WINDOW (x_dnd_frame)
&& x_dnd_return_frame == 1)
x_dnd_return_frame = 2;
if (x_dnd_return_frame == 2
- && x_any_window_to_frame (dpyinfo, target))
+ && x_any_window_to_frame (dpyinfo, toplevel))
{
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = event->xmotion.time;
+ lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &lmsg);
+ }
+
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
x_dnd_in_progress = false;
x_dnd_return_frame_object
- = x_any_window_to_frame (dpyinfo, target);
+ = x_any_window_to_frame (dpyinfo, toplevel);
x_dnd_return_frame = 3;
+ x_dnd_waiting_for_finish = false;
+ target = None;
}
- x_dnd_wanted_action = None;
+ x_dnd_last_seen_toplevel = toplevel;
+ }
+
+ if (target != x_dnd_last_seen_window)
+ {
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ /* This is apparently required. If we don't send
+ a motion event with the current root window
+ coordinates of the pointer before the top level
+ leave, then Motif displays an ugly black border
+ around the previous drop site. */
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DRAG_MOTION);
+ dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_NONE, XM_DRAG_NOOP,
+ XM_DROP_ACTION_DROP_CANCEL);
+ dmsg.timestamp = event->xmotion.time;
+ dmsg.x = event->xmotion.x_root;
+ dmsg.y = event->xmotion.y_root;
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = event->xbutton.time;
+ lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ {
+ xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &dmsg);
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &lmsg);
+ }
+ }
+
+ x_dnd_action = None;
x_dnd_last_seen_window = target;
x_dnd_last_protocol_version = target_proto;
+ x_dnd_last_motif_style = motif_style;
if (target != None && x_dnd_last_protocol_version != -1)
x_dnd_send_enter (x_dnd_frame, target,
x_dnd_last_protocol_version);
+ else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_ENTER);
+ emsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ emsg.zero = 0;
+ emsg.timestamp = event->xbutton.time;
+ emsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+ emsg.index_atom = dpyinfo->Xatom_XdndSelection;
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ target, &emsg);
+ }
}
if (x_dnd_last_protocol_version != -1 && target != None)
@@ -11719,13 +15203,35 @@ handle_one_xevent (struct x_display_info *dpyinfo,
event->xmotion.x_root,
event->xmotion.y_root,
x_dnd_selection_timestamp,
- dpyinfo->Xatom_XdndActionCopy);
+ x_dnd_wanted_action);
+ else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None)
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DRAG_MOTION);
+ dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ (!x_dnd_xm_use_help
+ ? XM_DROP_ACTION_DROP
+ : XM_DROP_ACTION_DROP_HELP));
+ dmsg.timestamp = event->xbutton.time;
+ dmsg.x = event->xmotion.x_root;
+ dmsg.y = event->xmotion.y_root;
+
+ if (x_dnd_motif_setup_p)
+ xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ target, &dmsg);
+ }
goto OTHER;
}
- f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window);
-
#ifdef USE_GTK
if (f && xg_event_is_for_scrollbar (f, event, false))
f = 0;
@@ -11788,7 +15294,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
last_mouse_window = window;
}
- if (!x_note_mouse_movement (f, &xmotion))
+ if (!x_note_mouse_movement (f, &xmotion, Qnil))
help_echo_string = previous_help_echo_string;
}
else
@@ -11846,6 +15352,63 @@ handle_one_xevent (struct x_display_info *dpyinfo,
configureEvent = next_event;
}
+ if (x_dnd_in_progress && x_dnd_use_toplevels
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
+ {
+ int rc, dest_x, dest_y;
+ Window child;
+ struct x_client_list_window *tem, *last = NULL;
+
+ for (tem = x_dnd_toplevels; tem; last = tem, tem = tem->next)
+ {
+ /* Not completely right, since the parent could be
+ unmapped, but good enough. */
+
+ if (tem->window == configureEvent.xconfigure.window)
+ {
+ x_catch_errors (dpyinfo->display);
+ rc = (XTranslateCoordinates (dpyinfo->display,
+ configureEvent.xconfigure.window,
+ dpyinfo->root_window,
+ -configureEvent.xconfigure.border_width,
+ -configureEvent.xconfigure.border_width,
+ &dest_x, &dest_y, &child)
+ && !x_had_errors_p (dpyinfo->display));
+ x_uncatch_errors_after_check ();
+
+ if (rc)
+ {
+ tem->x = dest_x;
+ tem->y = dest_y;
+ tem->width = (configureEvent.xconfigure.width
+ + configureEvent.xconfigure.border_width);
+ tem->height = (configureEvent.xconfigure.height
+ + configureEvent.xconfigure.border_width);
+ }
+ else
+ {
+ /* The window was probably destroyed, so get rid
+ of it. */
+
+ if (!last)
+ x_dnd_toplevels = tem->next;
+ else
+ last->next = tem->next;
+
+#ifdef HAVE_XSHAPE
+ if (tem->n_input_rects != -1)
+ xfree (tem->input_rects);
+ if (tem->n_bounding_rects != -1)
+ xfree (tem->bounding_rects);
+#endif
+ xfree (tem);
+ }
+
+ break;
+ }
+ }
+ }
+
#if defined HAVE_GTK3 && defined USE_TOOLKIT_SCROLL_BARS
struct scroll_bar *bar = x_window_to_scroll_bar (dpyinfo->display,
configureEvent.xconfigure.window, 2);
@@ -12042,6 +15605,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#endif
}
+
+ if (x_dnd_in_progress)
+ x_dnd_update_state (dpyinfo, dpyinfo->last_user_time);
goto OTHER;
case ButtonRelease:
@@ -12077,30 +15643,107 @@ handle_one_xevent (struct x_display_info *dpyinfo,
bool tool_bar_p = false;
bool dnd_grab = false;
- for (int i = 1; i < 8; ++i)
- {
- if (i != event->xbutton.button
- && event->xbutton.state & (Button1Mask << (i - 1)))
- dnd_grab = true;
- }
-
if (x_dnd_in_progress
- && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)
- && !dnd_grab
- && event->xbutton.type == ButtonRelease)
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
{
- x_dnd_in_progress = false;
+ for (int i = 1; i < 8; ++i)
+ {
+ if (i != event->xbutton.button
+ && event->xbutton.state & (Button1Mask << (i - 1)))
+ dnd_grab = true;
+ }
+
+ if (!dnd_grab && event->xbutton.type == ButtonRelease)
+ {
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_in_progress = false;
+
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1)
+ {
+ x_dnd_pending_finish_target = x_dnd_last_seen_window;
+ x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version;
+
+ x_dnd_waiting_for_finish
+ = x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window,
+ x_dnd_selection_timestamp,
+ x_dnd_last_protocol_version);
+ }
+ else if (x_dnd_last_seen_window != None)
+ {
+ xm_drop_start_message dmsg;
+ xm_drag_receiver_info drag_receiver_info;
+
+ if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window,
+ &drag_receiver_info)
+ && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE
+ && (x_dnd_allow_current_frame
+ || x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ {
+ memset (&dmsg, 0, sizeof dmsg);
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DROP_START);
+ dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ (!x_dnd_xm_use_help
+ ? XM_DROP_ACTION_DROP
+ : XM_DROP_ACTION_DROP_HELP));
+ dmsg.timestamp = event->xbutton.time;
+ dmsg.x = event->xbutton.x_root;
+ dmsg.y = event->xbutton.y_root;
+ dmsg.index_atom = dpyinfo->Xatom_XdndSelection;
+ dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (!XM_DRAG_STYLE_IS_DROP_ONLY (drag_receiver_info.protocol_style))
+ x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (x_dnd_frame),
+ x_dnd_frame, x_dnd_last_seen_window,
+ event->xbutton.time);
+
+ xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &dmsg);
+
+ x_dnd_waiting_for_finish = true;
+ x_dnd_waiting_for_motif_finish = 1;
+ }
+ }
+ else
+ {
+ x_set_pending_dnd_time (event->xbutton.time);
+ x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None
+ ? x_dnd_last_seen_toplevel
+ : x_dnd_last_seen_window),
+ event->xbutton.x_root, event->xbutton.y_root,
+ event->xbutton.time);
+ }
+ }
+ else if (x_dnd_last_seen_toplevel != None)
+ {
+ x_set_pending_dnd_time (event->xbutton.time);
+ x_dnd_send_unsupported_drop (dpyinfo, x_dnd_last_seen_toplevel,
+ event->xbutton.x_root,
+ event->xbutton.y_root,
+ event->xbutton.time);
+ }
- if (x_dnd_last_seen_window != None
- && x_dnd_last_protocol_version != -1)
- x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window,
- x_dnd_selection_timestamp,
- x_dnd_last_protocol_version);
- x_dnd_last_protocol_version = -1;
- x_dnd_last_seen_window = None;
- x_dnd_frame = NULL;
- x_set_dnd_targets (NULL, 0);
+ x_dnd_last_protocol_version = -1;
+ x_dnd_last_motif_style = XM_DRAG_STYLE_NONE;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_frame = NULL;
+ x_set_dnd_targets (NULL, 0);
+ }
goto OTHER;
}
@@ -12197,7 +15840,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
int y = event->xbutton.y;
window = window_from_coordinates (f, x, y, 0, true, true);
- tool_bar_p = EQ (window, f->tool_bar_window);
+ tool_bar_p = (EQ (window, f->tool_bar_window)
+ && (event->xbutton.type != ButtonRelease
+ || f->last_tool_bar_item != -1));
if (tool_bar_p && event->xbutton.button < 4)
handle_tool_bar_click
@@ -12320,6 +15965,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
break;
case CirculateNotify:
+ if (x_dnd_in_progress)
+ x_dnd_update_state (dpyinfo, dpyinfo->last_user_time);
goto OTHER;
case CirculateRequest:
@@ -12383,8 +16030,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case XI_FocusIn:
{
XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event;
+ struct xi_device_t *source;
any = x_any_window_to_frame (dpyinfo, focusin->event);
+ source = xi_device_from_id (dpyinfo, focusin->sourceid);
#ifdef USE_GTK
/* Some WMs (e.g. Mutter in Gnome Shell), don't unmap
minimized/iconified windows; thus, for those WMs we won't get
@@ -12412,16 +16061,25 @@ handle_one_xevent (struct x_display_info *dpyinfo,
XSETFRAME (inev.ie.frame_or_window, f);
}
}
+
x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+
+ if (inev.ie.kind != NO_EVENT && source)
+ inev.ie.device = source->name;
goto XI_OTHER;
}
case XI_FocusOut:
{
XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event;
+ struct xi_device_t *source;
any = x_any_window_to_frame (dpyinfo, focusout->event);
+ source = xi_device_from_id (dpyinfo, focusout->sourceid);
x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+
+ if (inev.ie.kind != NO_EVENT && source)
+ inev.ie.device = source->name;
goto XI_OTHER;
}
@@ -12429,8 +16087,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
XIEnterEvent *enter = (XIEnterEvent *) xi_event;
XMotionEvent ev;
+ struct xi_device_t *source;
any = x_top_window_to_frame (dpyinfo, enter->event);
+ source = xi_device_from_id (dpyinfo, enter->sourceid);
ev.x = lrint (enter->event_x);
ev.y = lrint (enter->event_y);
ev.window = enter->event;
@@ -12498,12 +16158,13 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* EnterNotify counts as mouse movement,
so update things that depend on mouse position. */
if (f && !f->output_data.x->hourglass_p)
- x_note_mouse_movement (f, &ev);
+ x_note_mouse_movement (f, &ev, source ? source->name : Qnil);
#ifdef USE_GTK
/* We may get an EnterNotify on the buttons in the toolbar. In that
case we moved out of any highlighted area and need to note this. */
if (!f && dpyinfo->last_mouse_glyph_frame)
- x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev);
+ x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev,
+ source ? source->name : Qnil);
#endif
goto XI_OTHER;
}
@@ -12512,6 +16173,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
XILeaveEvent *leave = (XILeaveEvent *) xi_event;
#ifdef USE_GTK
+ struct xi_device_t *source;
XMotionEvent ev;
ev.x = lrint (leave->event_x);
@@ -12522,6 +16184,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
any = x_top_window_to_frame (dpyinfo, leave->event);
+#ifdef USE_GTK
+ source = xi_device_from_id (dpyinfo, leave->sourceid);
+#endif
+
/* This allows us to catch LeaveNotify events generated by
popup menu grabs. FIXME: this is right when there is a
focus menu, but implicit focus tracking can get screwed
@@ -12624,14 +16290,15 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifdef USE_GTK
/* See comment in EnterNotify above */
else if (dpyinfo->last_mouse_glyph_frame)
- x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev);
+ x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev,
+ source ? source->name : Qnil);
#endif
goto XI_OTHER;
}
case XI_Motion:
{
- struct xi_device_t *device;
+ struct xi_device_t *device, *source;
#ifdef HAVE_XINPUT2_1
XIValuatorState *states;
double *values;
@@ -12639,6 +16306,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#endif
/* A fake XMotionEvent for x_note_mouse_movement. */
XMotionEvent ev;
+ xm_top_level_leave_message lmsg;
+ xm_top_level_enter_message emsg;
+ xm_drag_motion_message dmsg;
+
+ source = xi_device_from_id (dpyinfo, xev->sourceid);
#ifdef HAVE_XINPUT2_1
states = &xev->valuators;
@@ -12680,7 +16352,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* See the comment on top of
x_init_master_valuators for more details on how
scroll wheel movement is reported on XInput 2. */
- delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid,
+ delta = x_get_scroll_valuator_delta (dpyinfo, device,
i, *values, &val);
values++;
@@ -12855,6 +16527,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
XSETFRAME (inev.ie.frame_or_window, f);
}
+ if (source && source->name)
+ inev.ie.device = source->name;
+
goto XI_OTHER;
}
#ifdef HAVE_XWIDGETS
@@ -12907,43 +16582,148 @@ handle_one_xevent (struct x_display_info *dpyinfo,
clear_mouse_face (hlinfo);
}
+ f = mouse_or_wdesc_frame (dpyinfo, xev->event);
+
if (x_dnd_in_progress
&& dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
{
- Window target;
- int target_proto;
+ Window target, toplevel;
+ int target_proto, motif_style;
+
+ /* Sometimes the drag-and-drop operation starts with the
+ pointer of a frame invisible due to input. Since
+ motion events are ignored during that, make the pointer
+ visible manually. */
+
+ if (f)
+ XTtoggle_invisible_pointer (f, false);
target = x_dnd_get_target_window (dpyinfo,
xev->root_x,
xev->root_y,
- &target_proto);
+ &target_proto,
+ &motif_style,
+ &toplevel);
- if (target != x_dnd_last_seen_window)
+ if (toplevel != x_dnd_last_seen_toplevel)
{
- if (x_dnd_last_seen_window != None
- && x_dnd_last_protocol_version != -1
- && x_dnd_last_seen_window != FRAME_X_WINDOW (x_dnd_frame))
- x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
-
- if (x_dnd_last_seen_window == FRAME_X_WINDOW (x_dnd_frame)
+ if (toplevel != FRAME_OUTER_WINDOW (x_dnd_frame)
&& x_dnd_return_frame == 1)
x_dnd_return_frame = 2;
if (x_dnd_return_frame == 2
- && x_any_window_to_frame (dpyinfo, target))
+ && x_any_window_to_frame (dpyinfo, toplevel))
{
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = event->xmotion.time;
+ lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &lmsg);
+ }
+
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
x_dnd_in_progress = false;
x_dnd_return_frame_object
- = x_any_window_to_frame (dpyinfo, target);
+ = x_any_window_to_frame (dpyinfo, toplevel);
x_dnd_return_frame = 3;
+ x_dnd_waiting_for_finish = false;
+ target = None;
}
+ x_dnd_last_seen_toplevel = toplevel;
+ }
+
+ if (target != x_dnd_last_seen_window)
+ {
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window);
+ else if (x_dnd_last_seen_window != None
+ && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)
+ && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ /* This is apparently required. If we don't
+ send a motion event with the current root
+ window coordinates of the pointer before
+ the top level leave, then Motif displays
+ an ugly black border around the previous
+ drop site. */
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DRAG_MOTION);
+ dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_NONE, XM_DRAG_NOOP,
+ XM_DROP_ACTION_DROP_CANCEL);
+ dmsg.timestamp = xev->time;
+ dmsg.x = lrint (xev->root_x);
+ dmsg.y = lrint (xev->root_y);
+
+ lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_LEAVE);
+ lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ lmsg.zero = 0;
+ lmsg.timestamp = xev->time;
+ lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ {
+ xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &dmsg);
+ xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &lmsg);
+ }
+ }
+
+ x_dnd_action = None;
x_dnd_last_seen_window = target;
x_dnd_last_protocol_version = target_proto;
+ x_dnd_last_motif_style = motif_style;
if (target != None && x_dnd_last_protocol_version != -1)
x_dnd_send_enter (x_dnd_frame, target,
x_dnd_last_protocol_version);
+ else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_TOP_LEVEL_ENTER);
+ emsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ emsg.zero = 0;
+ emsg.timestamp = xev->time;
+ emsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+ emsg.index_atom = dpyinfo->Xatom_XdndSelection;
+
+ if (x_dnd_motif_setup_p)
+ xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ target, &emsg);
+ }
}
if (x_dnd_last_protocol_version != -1 && target != None)
@@ -12951,13 +16731,36 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_dnd_last_protocol_version,
xev->root_x, xev->root_y,
x_dnd_selection_timestamp,
- dpyinfo->Xatom_XdndActionCopy);
+ x_dnd_wanted_action);
+ else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None)
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DRAG_MOTION);
+ dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ (!x_dnd_xm_use_help
+ ? XM_DROP_ACTION_DROP
+ : XM_DROP_ACTION_DROP_HELP));
+ dmsg.timestamp = xev->time;
+ dmsg.x = lrint (xev->root_x);
+ dmsg.y = lrint (xev->root_y);
+
+ if (x_dnd_motif_setup_p)
+ xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ target, &dmsg);
+ }
goto XI_OTHER;
}
- f = mouse_or_wdesc_frame (dpyinfo, xev->event);
-
#ifdef USE_GTK
if (f && xg_event_is_for_scrollbar (f, event, false))
f = 0;
@@ -13005,13 +16808,16 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
inev.ie.kind = SELECT_WINDOW_EVENT;
inev.ie.frame_or_window = window;
+
+ if (source)
+ inev.ie.device = source->name;
}
/* Remember the last window where we saw the mouse. */
last_mouse_window = window;
}
- if (!x_note_mouse_movement (f, &ev))
+ if (!x_note_mouse_movement (f, &ev, source ? source->name : Qnil))
help_echo_string = previous_help_echo_string;
}
else
@@ -13045,7 +16851,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
Lisp_Object tab_bar_arg = Qnil;
bool tab_bar_p = false;
bool tool_bar_p = false;
- struct xi_device_t *device;
+ struct xi_device_t *device, *source;
#ifdef HAVE_XWIDGETS
struct xwidget_view *xvw;
#endif
@@ -13053,31 +16859,116 @@ handle_one_xevent (struct x_display_info *dpyinfo,
XButtonEvent bv;
bool dnd_grab = false;
- for (int i = 0; i < xev->buttons.mask_len * 8; ++i)
- {
- if (i != xev->detail && XIMaskIsSet (xev->buttons.mask, i))
- dnd_grab = true;
- }
-
if (x_dnd_in_progress
- && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)
- && !dnd_grab
- && xev->evtype == XI_ButtonRelease)
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
{
- x_dnd_in_progress = false;
+ for (int i = 0; i < xev->buttons.mask_len * 8; ++i)
+ {
+ if (i != xev->detail && XIMaskIsSet (xev->buttons.mask, i))
+ dnd_grab = true;
+ }
- if (x_dnd_last_seen_window != None
- && x_dnd_last_protocol_version != -1)
- x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window,
- x_dnd_selection_timestamp,
- x_dnd_last_protocol_version);
+ if (!dnd_grab
+ && xev->evtype == XI_ButtonRelease)
+ {
+ x_dnd_end_window = x_dnd_last_seen_window;
+ x_dnd_in_progress = false;
- x_dnd_last_protocol_version = -1;
- x_dnd_last_seen_window = None;
- x_dnd_frame = NULL;
- x_set_dnd_targets (NULL, 0);
+ if (x_dnd_last_seen_window != None
+ && x_dnd_last_protocol_version != -1)
+ {
+ x_dnd_pending_finish_target = x_dnd_last_seen_window;
+ x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version;
- goto XI_OTHER;
+ x_dnd_waiting_for_finish
+ = x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window,
+ x_dnd_selection_timestamp,
+ x_dnd_last_protocol_version);
+ }
+ else if (x_dnd_last_seen_window != None)
+ {
+ xm_drop_start_message dmsg;
+ xm_drag_receiver_info drag_receiver_info;
+
+ if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window,
+ &drag_receiver_info)
+ && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE
+ && (x_dnd_allow_current_frame
+ || x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)))
+ {
+ if (!x_dnd_motif_setup_p)
+ xm_setup_drag_info (dpyinfo, x_dnd_frame);
+
+ if (x_dnd_motif_setup_p)
+ {
+ memset (&dmsg, 0, sizeof dmsg);
+
+ dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR,
+ XM_DRAG_REASON_DROP_START);
+ dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST;
+ dmsg.side_effects
+ = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ XM_DROP_SITE_VALID,
+ xm_side_effect_from_action (dpyinfo,
+ x_dnd_wanted_action),
+ (!x_dnd_xm_use_help
+ ? XM_DROP_ACTION_DROP
+ : XM_DROP_ACTION_DROP_HELP));
+ dmsg.timestamp = xev->time;
+ dmsg.x = lrint (xev->root_x);
+ dmsg.y = lrint (xev->root_y);
+ /* This atom technically has to be
+ unique to each drag-and-drop
+ operation, but that isn't easy to
+ accomplish, since we cannot
+ randomly move data around between
+ selections. Let's hope no two
+ instances of Emacs try to drag
+ into the same window at the same
+ time. */
+ dmsg.index_atom = dpyinfo->Xatom_XdndSelection;
+ dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame);
+
+ if (!XM_DRAG_STYLE_IS_DROP_ONLY (drag_receiver_info.protocol_style))
+ x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (x_dnd_frame),
+ x_dnd_frame, x_dnd_last_seen_window,
+ xev->time);
+
+ xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame),
+ x_dnd_last_seen_window, &dmsg);
+
+ x_dnd_waiting_for_finish = true;
+ x_dnd_waiting_for_motif_finish = 1;
+ }
+ }
+ else
+ {
+ x_set_pending_dnd_time (xev->time);
+ x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None
+ ? x_dnd_last_seen_toplevel
+ : x_dnd_last_seen_window),
+ xev->root_x, xev->root_y, xev->time);
+ }
+ }
+ else if (x_dnd_last_seen_toplevel != None)
+ {
+ x_set_pending_dnd_time (xev->time);
+ x_dnd_send_unsupported_drop (dpyinfo,
+ x_dnd_last_seen_toplevel,
+ xev->root_x, xev->root_y,
+ xev->time);
+ }
+
+ x_dnd_last_protocol_version = -1;
+ x_dnd_last_motif_style = XM_DRAG_STYLE_NONE;
+ x_dnd_last_seen_window = None;
+ x_dnd_last_seen_toplevel = None;
+ x_dnd_frame = NULL;
+ x_set_dnd_targets (NULL, 0);
+
+ goto XI_OTHER;
+ }
}
if (x_dnd_in_progress)
@@ -13169,6 +17060,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (xev->evtype == XI_ButtonPress)
x_display_set_last_user_time (dpyinfo, xev->time);
+ source = xi_device_from_id (dpyinfo, xev->sourceid);
+
#ifdef HAVE_XWIDGETS
xvw = xwidget_view_from_window (xev->event);
if (xvw)
@@ -13181,6 +17074,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
inev.ie.kind = SELECT_WINDOW_EVENT;
inev.ie.frame_or_window = xvw->w;
+
+ if (source)
+ inev.ie.device = source->name;
}
*finish = X_EVENT_DROP;
@@ -13250,6 +17146,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
else
inev.ie.kind = HORIZ_WHEEL_EVENT;
+ if (source)
+ inev.ie.device = source->name;
+
inev.ie.timestamp = xev->time;
XSETINT (inev.ie.x, real_x);
@@ -13285,6 +17184,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
else
inev.ie.kind = HORIZ_WHEEL_EVENT;
+ if (source)
+ inev.ie.device = source->name;
+
inev.ie.timestamp = xev->time;
XSETINT (inev.ie.x, lrint (xev->event_x));
@@ -13328,12 +17230,22 @@ handle_one_xevent (struct x_display_info *dpyinfo,
int y = bv.y;
window = window_from_coordinates (f, x, y, 0, true, true);
- tool_bar_p = EQ (window, f->tool_bar_window);
+ /* Ignore button release events if the mouse
+ wasn't previously pressed on the tool bar.
+ We do this because otherwise selecting some
+ text with the mouse and then releasing it on
+ the tool bar doesn't stop selecting text,
+ since the tool bar eats the button up
+ event. */
+ tool_bar_p = (EQ (window, f->tool_bar_window)
+ && (xev->evtype != XI_ButtonRelease
+ || f->last_tool_bar_item != -1));
if (tool_bar_p && xev->detail < 4)
- handle_tool_bar_click
+ handle_tool_bar_click_with_device
(f, x, y, xev->evtype == XI_ButtonPress,
- x_x_to_emacs_modifiers (dpyinfo, bv.state));
+ x_x_to_emacs_modifiers (dpyinfo, bv.state),
+ source ? source->name : Qt);
}
#endif /* !USE_GTK */
@@ -13402,6 +17314,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
device->grab &= ~(1 << xev->detail);
}
+ if (source && inev.ie.kind != NO_EVENT)
+ inev.ie.device = source->name;
+
if (f)
f->mouse_moved = false;
@@ -13440,11 +17355,12 @@ handle_one_xevent (struct x_display_info *dpyinfo,
char *copy_bufptr = copy_buffer;
int copy_bufsiz = sizeof (copy_buffer);
ptrdiff_t i;
- struct xi_device_t *device;
+ struct xi_device_t *device, *source;
coding = Qlatin_1;
device = xi_device_from_id (dpyinfo, xev->deviceid);
+ source = xi_device_from_id (dpyinfo, xev->sourceid);
if (!device)
goto XI_OTHER;
@@ -13475,6 +17391,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
xkey.state = ((xev->mods.effective & ~(1 << 13 | 1 << 14))
| (xev->group.effective << 13));
+ xkey.x = lrint (xev->event_x);
+ xkey.y = lrint (xev->event_y);
+ xkey.x_root = lrint (xev->root_x);
+ xkey.y_root = lrint (xev->root_y);
+
/* Some input methods react differently depending on the
buttons that are pressed. */
if (xev->buttons.mask_len)
@@ -13497,12 +17418,24 @@ handle_one_xevent (struct x_display_info *dpyinfo,
|| (x_gtk_use_native_input
&& x_filter_event (dpyinfo, event)))
{
+ /* Try to attribute core key events from the input
+ method to the input extension event that caused
+ them. */
+ dpyinfo->pending_keystroke_time = xev->time;
+ dpyinfo->pending_keystroke_source = xev->sourceid;
+
*finish = X_EVENT_DROP;
goto XI_OTHER;
}
#else
if (x_filter_event (dpyinfo, (XEvent *) &xkey))
{
+ /* Try to attribute core key events from the input
+ method to the input extension event that caused
+ them. */
+ dpyinfo->pending_keystroke_time = xev->time;
+ dpyinfo->pending_keystroke_source = xev->sourceid;
+
*finish = X_EVENT_DROP;
goto XI_OTHER;
}
@@ -13512,6 +17445,12 @@ handle_one_xevent (struct x_display_info *dpyinfo,
|| dpyinfo->prefer_native_input)
&& xg_filter_key (any, event))
{
+ /* Try to attribute core key events from the input
+ method to the input extension event that caused
+ them. */
+ dpyinfo->pending_keystroke_time = xev->time;
+ dpyinfo->pending_keystroke_source = xev->sourceid;
+
*finish = X_EVENT_DROP;
goto XI_OTHER;
}
@@ -13666,6 +17605,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
}
+#ifdef XK_F1
+ if (x_dnd_in_progress && keysym == XK_F1)
+ {
+ x_dnd_xm_use_help = true;
+ goto xi_done_keysym;
+ }
+#endif
+
/* First deal with keysyms which have defined
translations to characters. */
if (keysym >= 32 && keysym < 128)
@@ -13674,6 +17621,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
inev.ie.kind = ASCII_KEYSTROKE_EVENT;
inev.ie.code = keysym;
+ if (source)
+ inev.ie.device = source->name;
+
goto xi_done_keysym;
}
@@ -13684,6 +17634,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
inev.ie.kind = ASCII_KEYSTROKE_EVENT;
else
inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT;
+
+ if (source)
+ inev.ie.device = source->name;
+
inev.ie.code = keysym & 0xFFFFFF;
goto xi_done_keysym;
}
@@ -13699,6 +17653,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
? ASCII_KEYSTROKE_EVENT
: MULTIBYTE_CHAR_KEYSTROKE_EVENT);
inev.ie.code = XFIXNAT (c);
+
+ if (source)
+ inev.ie.device = source->name;
+
goto xi_done_keysym;
}
@@ -13803,6 +17761,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
key. */
inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
inev.ie.code = keysym;
+
+ if (source)
+ inev.ie.device = source->name;
+
goto xi_done_keysym;
}
@@ -13818,6 +17780,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
Fput_text_property (make_fixnum (0), make_fixnum (nbytes),
Qcoding, coding, inev.ie.arg);
+
+ if (source)
+ inev.ie.device = source->name;
}
goto xi_done_keysym;
}
@@ -13825,6 +17790,21 @@ handle_one_xevent (struct x_display_info *dpyinfo,
goto XI_OTHER;
}
+#if defined USE_GTK && !defined HAVE_GTK3
+ case XI_RawKeyPress:
+ {
+ XIRawEvent *raw_event = (XIRawEvent *) xi_event;
+
+ /* This is the only way to attribute core keyboard
+ events generated on GTK+ 2.x to the extension device
+ that generated them. */
+ dpyinfo->pending_keystroke_time = raw_event->time;
+ dpyinfo->pending_keystroke_source = raw_event->sourceid;
+ dpyinfo->pending_keystroke_time_special_p = true;
+ goto XI_OTHER;
+ }
+#endif
+
case XI_KeyRelease:
#if defined HAVE_X_I18N || defined USE_GTK
{
@@ -13842,6 +17822,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
xkey.time = xev->time;
xkey.state = ((xev->mods.effective & ~(1 << 13 | 1 << 14))
| (xev->group.effective << 13));
+ xkey.x = lrint (xev->event_x);
+ xkey.y = lrint (xev->event_y);
+ xkey.x_root = lrint (xev->root_x);
+ xkey.y_root = lrint (xev->root_y);
/* Some input methods react differently depending on the
buttons that are pressed. */
@@ -13876,8 +17860,103 @@ handle_one_xevent (struct x_display_info *dpyinfo,
goto XI_OTHER;
case XI_HierarchyChanged:
- x_init_master_valuators (dpyinfo);
- goto XI_OTHER;
+ {
+ XIHierarchyEvent *hev = (XIHierarchyEvent *) xi_event;
+ XIDeviceInfo *info;
+ int i, j, ndevices, n_disabled, *disabled;
+ struct xi_device_t *device, *devices;
+#ifdef HAVE_XINPUT2_2
+ struct xi_touch_point_t *tem, *last;
+#endif
+
+ disabled = alloca (sizeof *disabled * hev->num_info);
+ n_disabled = 0;
+
+ for (i = 0; i < hev->num_info; ++i)
+ {
+ if (hev->info[i].flags & XIDeviceEnabled)
+ {
+ x_catch_errors (dpyinfo->display);
+ info = XIQueryDevice (dpyinfo->display, hev->info[i].deviceid,
+ &ndevices);
+ x_uncatch_errors ();
+
+ if (info && info->enabled)
+ {
+ dpyinfo->devices
+ = xrealloc (dpyinfo->devices, (sizeof *dpyinfo->devices
+ * ++dpyinfo->num_devices));
+ device = &dpyinfo->devices[dpyinfo->num_devices - 1];
+ xi_populate_device_from_info (device, info);
+ }
+
+ if (info)
+ XIFreeDeviceInfo (info);
+ }
+ else if (hev->info[i].flags & XIDeviceDisabled)
+ disabled[n_disabled++] = hev->info[i].deviceid;
+ else if (hev->info[i].flags & XISlaveDetached
+ || hev->info[i].flags & XISlaveAttached)
+ {
+ device = xi_device_from_id (dpyinfo, hev->info[i].deviceid);
+ x_catch_errors (dpyinfo->display);
+ info = XIQueryDevice (dpyinfo->display, hev->info[i].deviceid,
+ &ndevices);
+ x_uncatch_errors ();
+
+ if (info)
+ {
+ if (device && info->enabled)
+ device->master_p = (info->use == XIMasterKeyboard
+ || info->use == XIMasterPointer);
+ else if (device)
+ disabled[n_disabled++] = hev->info[i].deviceid;
+
+ XIFreeDeviceInfo (info);
+ }
+ }
+ }
+
+ if (n_disabled)
+ {
+ ndevices = 0;
+ devices = xmalloc (sizeof *devices * dpyinfo->num_devices);
+
+ for (i = 0; i < dpyinfo->num_devices; ++i)
+ {
+ for (j = 0; j < n_disabled; ++j)
+ {
+ if (disabled[j] == dpyinfo->devices[i].device_id)
+ {
+#ifdef HAVE_XINPUT2_1
+ xfree (dpyinfo->devices[i].valuators);
+#endif
+#ifdef HAVE_XINPUT2_2
+ tem = dpyinfo->devices[i].touchpoints;
+ while (tem)
+ {
+ last = tem;
+ tem = tem->next;
+ xfree (last);
+ }
+#endif
+ goto continue_detachment;
+ }
+ }
+
+ devices[ndevices++] = dpyinfo->devices[i];
+
+ continue_detachment:
+ continue;
+ }
+
+ xfree (dpyinfo->devices);
+ dpyinfo->devices = devices;
+ dpyinfo->num_devices = ndevices;
+ }
+
+ goto XI_OTHER;
+ }
case XI_DeviceChanged:
{
@@ -14012,12 +18091,13 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifdef HAVE_XINPUT2_2
case XI_TouchBegin:
{
- struct xi_device_t *device;
+ struct xi_device_t *device, *source;
bool menu_bar_p = false, tool_bar_p = false;
#ifdef HAVE_GTK3
GdkRectangle test_rect;
#endif
device = xi_device_from_id (dpyinfo, xev->deviceid);
+ source = xi_device_from_id (dpyinfo, xev->sourceid);
x_display_set_last_user_time (dpyinfo, xev->time);
if (!device)
@@ -14050,10 +18130,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (f && device->direct_p)
{
*finish = X_EVENT_DROP;
- x_catch_errors (dpyinfo->display);
if (x_input_grab_touch_events)
XIAllowTouchEvents (dpyinfo->display, xev->deviceid,
xev->detail, xev->event, XIAcceptTouch);
+
if (!x_had_errors_p (dpyinfo->display))
{
xi_link_touch_point (device, xev->detail, xev->event_x,
@@ -14065,18 +18145,15 @@ handle_one_xevent (struct x_display_info *dpyinfo,
XSETINT (inev.ie.x, lrint (xev->event_x));
XSETINT (inev.ie.y, lrint (xev->event_y));
XSETINT (inev.ie.arg, xev->detail);
+
+ if (source)
+ inev.ie.device = source->name;
}
- x_uncatch_errors_after_check ();
}
#ifndef HAVE_GTK3
- else
- {
- x_catch_errors (dpyinfo->display);
- if (x_input_grab_touch_events)
- XIAllowTouchEvents (dpyinfo->display, xev->deviceid,
- xev->detail, xev->event, XIRejectTouch);
- x_uncatch_errors ();
- }
+ else if (x_input_grab_touch_events)
+ XIAllowTouchEvents (dpyinfo->display, xev->deviceid,
+ xev->detail, xev->event, XIRejectTouch);
#endif
}
else
@@ -14098,11 +18175,12 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case XI_TouchUpdate:
{
- struct xi_device_t *device;
+ struct xi_device_t *device, *source;
struct xi_touch_point_t *touchpoint;
Lisp_Object arg = Qnil;
device = xi_device_from_id (dpyinfo, xev->deviceid);
+ source = xi_device_from_id (dpyinfo, xev->sourceid);
x_display_set_last_user_time (dpyinfo, xev->time);
if (!device)
@@ -14133,6 +18211,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
arg);
}
+ if (source)
+ inev.ie.device = source->name;
+
inev.ie.arg = arg;
}
@@ -14141,10 +18222,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case XI_TouchEnd:
{
- struct xi_device_t *device;
+ struct xi_device_t *device, *source;
bool unlinked_p;
device = xi_device_from_id (dpyinfo, xev->deviceid);
+ source = xi_device_from_id (dpyinfo, xev->sourceid);
x_display_set_last_user_time (dpyinfo, xev->time);
if (!device)
@@ -14160,10 +18242,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
inev.ie.kind = TOUCHSCREEN_END_EVENT;
inev.ie.timestamp = xev->time;
+
XSETFRAME (inev.ie.frame_or_window, f);
XSETINT (inev.ie.x, lrint (xev->event_x));
XSETINT (inev.ie.y, lrint (xev->event_y));
XSETINT (inev.ie.arg, xev->detail);
+
+ if (source)
+ inev.ie.device = source->name;
}
}
@@ -14176,10 +18262,12 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case XI_GesturePinchBegin:
case XI_GesturePinchUpdate:
{
- x_display_set_last_user_time (dpyinfo, xi_event->time);
-
XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event;
- struct xi_device_t *device = xi_device_from_id (dpyinfo, pev->deviceid);
+ struct xi_device_t *device, *source;
+
+ device = xi_device_from_id (dpyinfo, pev->deviceid);
+ source = xi_device_from_id (dpyinfo, pev->sourceid);
+ x_display_set_last_user_time (dpyinfo, xi_event->time);
if (!device)
goto XI_OTHER;
@@ -14208,6 +18296,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
make_float (pev->delta_y),
make_float (pev->scale),
make_float (pev->delta_angle));
+
+ if (source)
+ inev.ie.device = source->name;
}
/* Once again GTK seems to crash when confronted by
@@ -14257,7 +18348,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
default:
#ifdef HAVE_XKB
- if (event->type == dpyinfo->xkb_event_type)
+ if (dpyinfo->supports_xkb
+ && event->type == dpyinfo->xkb_event_type)
{
XkbEvent *xkbevent = (XkbEvent *) event;
@@ -14303,6 +18395,216 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
}
#endif
+#ifdef HAVE_XSHAPE
+ if (dpyinfo->xshape_supported_p
+ && event->type == dpyinfo->xshape_event_base + ShapeNotify
+ && x_dnd_in_progress && x_dnd_use_toplevels
+ && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame))
+ {
+ XEvent xevent;
+ XShapeEvent *xse = (XShapeEvent *) event;
+#if defined HAVE_XCB_SHAPE && defined HAVE_XCB_SHAPE_INPUT_RECTS
+ xcb_shape_get_rectangles_cookie_t bounding_rect_cookie;
+ xcb_shape_get_rectangles_reply_t *bounding_rect_reply;
+ xcb_rectangle_iterator_t bounding_rect_iterator;
+
+ xcb_shape_get_rectangles_cookie_t input_rect_cookie;
+ xcb_shape_get_rectangles_reply_t *input_rect_reply;
+ xcb_rectangle_iterator_t input_rect_iterator;
+
+ xcb_generic_error_t *error;
+#else
+ XRectangle *rects;
+ int rc, ordering;
+#endif
+
+ while (XPending (dpyinfo->display))
+ {
+ XNextEvent (dpyinfo->display, &xevent);
+
+ if (xevent.type == dpyinfo->xshape_event_base + ShapeNotify
+ && ((XShapeEvent *) &xevent)->window == xse->window)
+ xse = (XShapeEvent *) &xevent;
+ else
+ {
+ XPutBackEvent (dpyinfo->display, &xevent);
+ break;
+ }
+ }
+
+ for (struct x_client_list_window *tem = x_dnd_toplevels; tem;
+ tem = tem->next)
+ {
+ if (tem->window == xse->window)
+ {
+ if (tem->n_input_rects != -1)
+ xfree (tem->input_rects);
+ if (tem->n_bounding_rects != -1)
+ xfree (tem->bounding_rects);
+
+ tem->n_input_rects = -1;
+ tem->n_bounding_rects = -1;
+
+#if defined HAVE_XCB_SHAPE && defined HAVE_XCB_SHAPE_INPUT_RECTS
+ bounding_rect_cookie = xcb_shape_get_rectangles (dpyinfo->xcb_connection,
+ (xcb_window_t) xse->window,
+ XCB_SHAPE_SK_BOUNDING);
+ if (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1))
+ input_rect_cookie
+ = xcb_shape_get_rectangles (dpyinfo->xcb_connection,
+ (xcb_window_t) xse->window,
+ XCB_SHAPE_SK_INPUT);
+
+ bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ bounding_rect_cookie,
+ &error);
+
+ if (bounding_rect_reply)
+ {
+ bounding_rect_iterator
+ = xcb_shape_get_rectangles_rectangles_iterator (bounding_rect_reply);
+ tem->n_bounding_rects = bounding_rect_iterator.rem + 1;
+ tem->bounding_rects = xmalloc (tem->n_bounding_rects
+ * sizeof *tem->bounding_rects);
+ tem->n_bounding_rects = 0;
+
+ for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator))
+ {
+ tem->bounding_rects[tem->n_bounding_rects].x
+ = bounding_rect_iterator.data->x;
+ tem->bounding_rects[tem->n_bounding_rects].y
+ = bounding_rect_iterator.data->y;
+ tem->bounding_rects[tem->n_bounding_rects].width
+ = bounding_rect_iterator.data->width;
+ tem->bounding_rects[tem->n_bounding_rects].height
+ = bounding_rect_iterator.data->height;
+
+ tem->n_bounding_rects++;
+ }
+
+ free (bounding_rect_reply);
+ }
+ else
+ free (error);
+
+ if (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1))
+ {
+ input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ input_rect_cookie, &error);
+
+ if (input_rect_reply)
+ {
+ input_rect_iterator
+ = xcb_shape_get_rectangles_rectangles_iterator (input_rect_reply);
+ tem->n_input_rects = input_rect_iterator.rem + 1;
+ tem->input_rects = xmalloc (tem->n_input_rects
+ * sizeof *tem->input_rects);
+ tem->n_input_rects = 0;
+
+ for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator))
+ {
+ tem->input_rects[tem->n_input_rects].x
+ = input_rect_iterator.data->x;
+ tem->input_rects[tem->n_input_rects].y
+ = input_rect_iterator.data->y;
+ tem->input_rects[tem->n_input_rects].width
+ = input_rect_iterator.data->width;
+ tem->input_rects[tem->n_input_rects].height
+ = input_rect_iterator.data->height;
+
+ tem->n_input_rects++;
+ }
+
+ free (input_rect_reply);
+ }
+ else
+ free (error);
+ }
+#else
+ x_catch_errors (dpyinfo->display);
+ rects = XShapeGetRectangles (dpyinfo->display,
+ xse->window,
+ ShapeBounding,
+ &count, &ordering);
+ rc = x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+
+ /* Does XShapeGetRectangles allocate anything upon an
+ error? */
+ if (!rc)
+ {
+ tem->n_bounding_rects = count;
+ tem->bounding_rects
+ = xmalloc (sizeof *tem->bounding_rects * count);
+ memcpy (tem->bounding_rects, rects,
+ sizeof *tem->bounding_rects * count);
+
+ XFree (rects);
+ }
+
+#ifdef ShapeInput
+ if (dpyinfo->xshape_major > 1
+ || (dpyinfo->xshape_major == 1
+ && dpyinfo->xshape_minor >= 1))
+ {
+ x_catch_errors (dpyinfo->display);
+ rects = XShapeGetRectangles (dpyinfo->display,
+ xse->window, ShapeInput,
+ &count, &ordering);
+ rc = x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+
+ /* Does XShapeGetRectangles allocate anything upon
+ an error? */
+ if (!rc)
+ {
+ tem->n_input_rects = count;
+ tem->input_rects
+ = xmalloc (sizeof *tem->input_rects * count);
+ memcpy (tem->input_rects, rects,
+ sizeof *tem->input_rects * count);
+
+ XFree (rects);
+ }
+ }
+#endif
+#endif
+
+ /* Handle the common case where the input shape equals the
+ bounding shape. */
+
+ if (tem->n_input_rects != -1
+ && tem->n_bounding_rects == tem->n_input_rects
+ && !memcmp (tem->bounding_rects, tem->input_rects,
+ tem->n_input_rects * sizeof *tem->input_rects))
+ {
+ xfree (tem->input_rects);
+ tem->n_input_rects = -1;
+ }
+
+ /* And the common case where there is no input rect and the
+ bouding rect equals the window dimensions. */
+
+ if (tem->n_input_rects == -1
+ && tem->n_bounding_rects == 1
+ && tem->bounding_rects[0].width == tem->width
+ && tem->bounding_rects[0].height == tem->height
+ && tem->bounding_rects[0].x == -tem->border_width
+ && tem->bounding_rects[0].y == -tem->border_width)
+ {
+ xfree (tem->bounding_rects);
+ tem->n_bounding_rects = -1;
+ }
+
+ break;
+ }
+ }
+ }
+#endif
OTHER:
#ifdef USE_X_TOOLKIT
block_input ();
@@ -14438,8 +18740,19 @@ XTread_socket (struct terminal *terminal, struct input_event *hold_quit)
#ifdef HAVE_X_I18N
/* Filter events for the current X input method. */
- if (x_filter_event (dpyinfo, &event))
- continue;
+#ifdef HAVE_XINPUT2
+ if (event.type != GenericEvent
+ || !dpyinfo->supports_xi2
+ || event.xgeneric.extension != dpyinfo->xi2_opcode)
+ {
+ /* Input extension key events are filtered inside
+ handle_one_xevent. */
+#endif
+ if (x_filter_event (dpyinfo, &event))
+ continue;
+#ifdef HAVE_XINPUT2
+ }
+#endif
#endif
event_found = true;
@@ -15222,6 +19535,10 @@ static void x_error_quitter (Display *, XErrorEvent *);
static int
x_error_handler (Display *display, XErrorEvent *event)
{
+#ifdef HAVE_XINPUT2
+ struct x_display_info *dpyinfo;
+#endif
+
#if defined USE_GTK && defined HAVE_GTK3
if ((event->error_code == BadMatch || event->error_code == BadWindow)
&& event->request_code == X_SetInputFocus)
@@ -15230,6 +19547,24 @@ x_error_handler (Display *display, XErrorEvent *event)
}
#endif
+ /* If we try to ungrab or grab a device that doesn't exist anymore
+ (that happens a lot in xmenu.c), just ignore the error. */
+
+#ifdef HAVE_XINPUT2
+ dpyinfo = x_display_info_for_display (display);
+
+ /* 51 is X_XIGrabDevice and 52 is X_XIUngrabDevice.
+
+ 53 is X_XIAllowEvents. We handle errors from that here to avoid
+ a sync in handle_one_xevent. */
+ if (dpyinfo && dpyinfo->supports_xi2
+ && event->request_code == dpyinfo->xi2_opcode
+ && (event->minor_code == 51
+ || event->minor_code == 52
+ || event->minor_code == 53))
+ return 0;
+#endif
+
if (x_error_message)
x_error_catcher (display, event);
else
@@ -15437,6 +19772,9 @@ xim_instantiate_callback (Display *display, XPointer client_data, XPointer call_
struct xim_inst_t *xim_inst = (struct xim_inst_t *) client_data;
struct x_display_info *dpyinfo = xim_inst->dpyinfo;
+ if (x_dnd_in_progress)
+ return;
+
/* We don't support multiple XIM connections. */
if (dpyinfo->xim)
return;
@@ -16555,16 +20893,17 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
if (FRAME_DISPLAY_INFO (f)->supports_xi2)
{
- XGrabServer (FRAME_X_DISPLAY (f));
- if (XIGetClientPointer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ if (XIGetClientPointer (FRAME_X_DISPLAY (f),
+ FRAME_X_WINDOW (f),
&deviceid))
{
+ x_catch_errors (FRAME_X_DISPLAY (f));
XIWarpPointer (FRAME_X_DISPLAY (f),
deviceid, None,
FRAME_X_WINDOW (f),
0, 0, 0, 0, pix_x, pix_y);
+ x_uncatch_errors ();
}
- XUngrabServer (FRAME_X_DISPLAY (f));
}
else
#endif
@@ -17169,16 +21508,6 @@ x_free_frame_resources (struct frame *f)
struct scroll_bar *b;
#endif
- if (x_dnd_in_progress && f == x_dnd_frame)
- {
- if (x_dnd_last_seen_window != None
- && x_dnd_last_protocol_version != -1)
- x_dnd_send_leave (f, x_dnd_last_seen_window);
-
- x_dnd_in_progress = false;
- x_dnd_frame = NULL;
- }
-
block_input ();
/* If a display connection is dead, don't try sending more
@@ -17342,10 +21671,6 @@ x_free_frame_resources (struct frame *f)
g_object_unref (FRAME_OUTPUT_DATA (f)->scrollbar_foreground_css_provider);
#endif
- xfree (f->output_data.x->saved_menu_event);
- xfree (f->output_data.x);
- f->output_data.x = NULL;
-
if (f == dpyinfo->x_focus_frame)
dpyinfo->x_focus_frame = 0;
if (f == dpyinfo->x_focus_event_frame)
@@ -17371,6 +21696,10 @@ x_destroy_window (struct frame *f)
if (dpyinfo->display != 0)
x_free_frame_resources (f);
+ xfree (f->output_data.x->saved_menu_event);
+ xfree (f->output_data.x);
+ f->output_data.x = NULL;
+
dpyinfo->reference_count--;
}
@@ -17910,6 +22239,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
#ifdef USE_XCB
xcb_connection_t *xcb_conn;
#endif
+ char *cm_atom_sprintf;
block_input ();
@@ -18191,6 +22521,33 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
&dpyinfo->xrender_minor);
#endif
+ /* This must come after XRenderQueryVersion! */
+#ifdef HAVE_XCOMPOSITE
+ int composite_event_base, composite_error_base;
+ dpyinfo->composite_supported_p = XCompositeQueryExtension (dpyinfo->display,
+ &composite_event_base,
+ &composite_error_base);
+
+ if (dpyinfo->composite_supported_p)
+ dpyinfo->composite_supported_p
+ = XCompositeQueryVersion (dpyinfo->display,
+ &dpyinfo->composite_major,
+ &dpyinfo->composite_minor);
+#endif
+
+#ifdef HAVE_XSHAPE
+ dpyinfo->xshape_supported_p
+ = XShapeQueryExtension (dpyinfo->display,
+ &dpyinfo->xshape_event_base,
+ &dpyinfo->xshape_error_base);
+
+ if (dpyinfo->xshape_supported_p)
+ dpyinfo->xshape_supported_p
+ = XShapeQueryVersion (dpyinfo->display,
+ &dpyinfo->xshape_major,
+ &dpyinfo->xshape_minor);
+#endif
+
/* Put the rdb where we can find it in a way that works on
all versions. */
dpyinfo->rdb = xrdb;
@@ -18550,6 +22907,15 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
}
{
+ int n = snprintf (NULL, 0, "_NET_WM_CM_S%d",
+ XScreenNumberOfScreen (dpyinfo->screen));
+ cm_atom_sprintf = alloca (n + 1);
+
+ snprintf (cm_atom_sprintf, n + 1, "_NET_WM_CM_S%d",
+ XScreenNumberOfScreen (dpyinfo->screen));
+ }
+
+ {
static const struct
{
const char *name;
@@ -18562,6 +22928,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
ATOM_REFS_INIT ("WM_SAVE_YOURSELF", Xatom_wm_save_yourself)
ATOM_REFS_INIT ("WM_DELETE_WINDOW", Xatom_wm_delete_window)
ATOM_REFS_INIT ("WM_CHANGE_STATE", Xatom_wm_change_state)
+ ATOM_REFS_INIT ("WM_STATE", Xatom_wm_state)
ATOM_REFS_INIT ("WM_CONFIGURE_DENIED", Xatom_wm_configure_denied)
ATOM_REFS_INIT ("WM_MOVED", Xatom_wm_window_moved)
ATOM_REFS_INIT ("WM_CLIENT_LEADER", Xatom_wm_client_leader)
@@ -18584,6 +22951,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
ATOM_REFS_INIT ("CLIPBOARD_MANAGER", Xatom_CLIPBOARD_MANAGER)
ATOM_REFS_INIT ("XATOM_COUNTER", Xatom_XEMBED_INFO)
ATOM_REFS_INIT ("_XEMBED_INFO", Xatom_XEMBED_INFO)
+ ATOM_REFS_INIT ("_MOTIF_WM_HINTS", Xatom_MOTIF_WM_HINTS)
/* For properties of font. */
ATOM_REFS_INIT ("PIXEL_SIZE", Xatom_PIXEL_SIZE)
ATOM_REFS_INIT ("AVERAGE_WIDTH", Xatom_AVERAGE_WIDTH)
@@ -18623,6 +22991,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
ATOM_REFS_INIT ("_NET_WM_FRAME_DRAWN", Xatom_net_wm_frame_drawn)
ATOM_REFS_INIT ("_NET_WM_USER_TIME", Xatom_net_wm_user_time)
ATOM_REFS_INIT ("_NET_WM_USER_TIME_WINDOW", Xatom_net_wm_user_time_window)
+ ATOM_REFS_INIT ("_NET_CLIENT_LIST_STACKING", Xatom_net_client_list_stacking)
/* Session management */
ATOM_REFS_INIT ("SM_CLIENT_ID", Xatom_SM_CLIENT_ID)
ATOM_REFS_INIT ("_XSETTINGS_SETTINGS", Xatom_xsettings_prop)
@@ -18632,6 +23001,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
ATOM_REFS_INIT ("_NET_WM_STATE_BELOW", Xatom_net_wm_state_below)
ATOM_REFS_INIT ("_NET_WM_OPAQUE_REGION", Xatom_net_wm_opaque_region)
ATOM_REFS_INIT ("_NET_WM_PING", Xatom_net_wm_ping)
+ ATOM_REFS_INIT ("_NET_WM_PID", Xatom_net_wm_pid)
#ifdef HAVE_XKB
ATOM_REFS_INIT ("Meta", Xatom_Meta)
ATOM_REFS_INIT ("Super", Xatom_Super)
@@ -18657,12 +23027,23 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
ATOM_REFS_INIT ("XdndLeave", Xatom_XdndLeave)
ATOM_REFS_INIT ("XdndDrop", Xatom_XdndDrop)
ATOM_REFS_INIT ("XdndFinished", Xatom_XdndFinished)
+ /* Motif drop protocol support. */
+ ATOM_REFS_INIT ("_MOTIF_DRAG_WINDOW", Xatom_MOTIF_DRAG_WINDOW)
+ ATOM_REFS_INIT ("_MOTIF_DRAG_TARGETS", Xatom_MOTIF_DRAG_TARGETS)
+ ATOM_REFS_INIT ("_MOTIF_DRAG_AND_DROP_MESSAGE",
+ Xatom_MOTIF_DRAG_AND_DROP_MESSAGE)
+ ATOM_REFS_INIT ("_MOTIF_DRAG_INITIATOR_INFO",
+ Xatom_MOTIF_DRAG_INITIATOR_INFO)
+ ATOM_REFS_INIT ("_MOTIF_DRAG_RECEIVER_INFO",
+ Xatom_MOTIF_DRAG_RECEIVER_INFO)
+ ATOM_REFS_INIT ("XmTRANSFER_SUCCESS", Xatom_XmTRANSFER_SUCCESS)
+ ATOM_REFS_INIT ("XmTRANSFER_FAILURE", Xatom_XmTRANSFER_FAILURE)
};
int i;
enum { atom_count = ARRAYELTS (atom_refs) };
/* 1 for _XSETTINGS_SN. */
- enum { total_atom_count = 1 + atom_count };
+ enum { total_atom_count = 2 + atom_count };
Atom atoms_return[total_atom_count];
char *atom_names[total_atom_count];
static char const xsettings_fmt[] = "_XSETTINGS_S%d";
@@ -18676,6 +23057,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
sprintf (xsettings_atom_name, xsettings_fmt,
XScreenNumberOfScreen (dpyinfo->screen));
atom_names[i] = xsettings_atom_name;
+ atom_names[i + 1] = cm_atom_sprintf;
XInternAtoms (dpyinfo->display, atom_names, total_atom_count,
False, atoms_return);
@@ -18683,8 +23065,9 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
for (i = 0; i < atom_count; i++)
*(Atom *) ((char *) dpyinfo + atom_refs[i].offset) = atoms_return[i];
- /* Manually copy last atom. */
+ /* Manually copy last two atoms. */
dpyinfo->Xatom_xsettings_sel = atoms_return[i];
+ dpyinfo->Xatom_NET_WM_CM_Sn = atoms_return[i + 1];
}
#ifdef HAVE_XKB
@@ -19193,65 +23576,35 @@ init_xterm (void)
}
#endif
-#ifdef HAVE_XRENDER
void
-x_xrender_color_from_gc_foreground (struct frame *f, GC gc, XRenderColor *color,
- bool apply_alpha_background)
+mark_xterm (void)
{
- XGCValues xgcv;
- XColor xc;
-
- XGetGCValues (FRAME_X_DISPLAY (f), gc, GCForeground, &xgcv);
- xc.pixel = xgcv.foreground;
- x_query_colors (f, &xc, 1);
-
- color->alpha = (apply_alpha_background
- ? 65535 * f->alpha_background
- : 65535);
+ Lisp_Object val;
+#ifdef HAVE_XINPUT2
+ struct x_display_info *dpyinfo;
+ int i;
+#endif
- if (color->alpha == 65535)
+ if (x_dnd_return_frame_object)
{
- color->red = xc.red;
- color->blue = xc.blue;
- color->green = xc.green;
+ XSETFRAME (val, x_dnd_return_frame_object);
+ mark_object (val);
}
- else
- {
- color->red = (xc.red * color->alpha) / 65535;
- color->blue = (xc.blue * color->alpha) / 65535;
- color->green = (xc.green * color->alpha) / 65535;
- }
-}
-void
-x_xrender_color_from_gc_background (struct frame *f, GC gc, XRenderColor *color,
- bool apply_alpha_background)
-{
- XGCValues xgcv;
- XColor xc;
-
- XGetGCValues (FRAME_X_DISPLAY (f), gc, GCBackground, &xgcv);
- xc.pixel = xgcv.background;
- x_query_colors (f, &xc, 1);
-
- color->alpha = (apply_alpha_background
- ? 65535 * f->alpha_background
- : 65535);
-
- if (color->alpha == 65535)
+ if (x_dnd_movement_frame)
{
- color->red = xc.red;
- color->blue = xc.blue;
- color->green = xc.green;
+ XSETFRAME (val, x_dnd_movement_frame);
+ mark_object (val);
}
- else
+
+#ifdef HAVE_XINPUT2
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
{
- color->red = (xc.red * color->alpha) / 65535;
- color->blue = (xc.blue * color->alpha) / 65535;
- color->green = (xc.green * color->alpha) / 65535;
+ for (i = 0; i < dpyinfo->num_devices; ++i)
+ mark_object (dpyinfo->devices[i].name);
}
-}
#endif
+}
void
syms_of_xterm (void)
@@ -19261,6 +23614,7 @@ syms_of_xterm (void)
DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms");
DEFSYM (Qlatin_1, "latin-1");
+ DEFSYM (Qnow, "now");
#ifdef USE_GTK
xg_default_icon_file = build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg");
@@ -19443,4 +23797,34 @@ reliably continue to receive updates even if the finger moves off the
frame, but may cause crashes with some window managers and/or external
programs. */);
x_input_grab_touch_events = true;
+
+ DEFVAR_BOOL ("x-dnd-fix-motif-leave", x_dnd_fix_motif_leave,
+ doc: /* Work around Motif bug during drag-and-drop.
+When non-nil, Emacs will send a motion event containing impossible
+coordinates to a Motif drop receiver when the mouse moves outside it
+during a drag-and-drop session, to work around broken implementations
+of Motif. */);
+ x_dnd_fix_motif_leave = true;
+
+ DEFVAR_LISP ("x-dnd-movement-function", Vx_dnd_movement_function,
+ doc: /* Function called upon mouse movement on a frame during drag-and-drop.
+It should either be nil, or accept two arguments FRAME and POSITION,
+where FRAME is the frame the mouse is on top of, and POSITION is a
+mouse position list. */);
+ Vx_dnd_movement_function = Qnil;
+
+ DEFVAR_LISP ("x-dnd-unsupported-drop-function", Vx_dnd_unsupported_drop_function,
+ doc: /* Function called when trying to drop on an unsupported window.
+This function is called whenever the user tries to drop
+something on a window that does not support either the XDND or
+Motif protocols for drag-and-drop. It should return a non-nil
+value if the drop was handled by the function, and nil if it was
+not. It should accept several arguments TARGETS, X, Y, ACTION,
+WINDOW-ID and FRAME, where TARGETS is the list of targets that
+was passed to `x-begin-drag', WINDOW-ID is the numeric XID of
+the window that is being dropped on, X and Y are the root
+window-relative coordinates where the drop happened, ACTION
+is the action that was passed to `x-begin-drag', and FRAME is
+the frame which initiated the drag-and-drop operation. */);
+ Vx_dnd_unsupported_drop_function = Qnil;
}
diff --git a/src/xterm.h b/src/xterm.h
index 9665e92a9fb..69313166db9 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -244,6 +244,8 @@ struct xi_device_t
#ifdef HAVE_XINPUT2_2
struct xi_touch_point_t *touchpoints;
#endif
+
+ Lisp_Object name;
};
#endif
@@ -396,6 +398,7 @@ struct x_display_info
/* Atom for indicating window state to the window manager. */
Atom Xatom_wm_change_state;
+ Atom Xatom_wm_state;
/* Other WM communication */
Atom Xatom_wm_configure_denied; /* When our config request is denied */
@@ -429,6 +432,15 @@ struct x_display_info
/* Atom used in XEmbed client messages. */
Atom Xatom_XEMBED, Xatom_XEMBED_INFO;
+ /* Atom used to determine whether or not the screen is composited. */
+ Atom Xatom_NET_WM_CM_Sn;
+
+ Atom Xatom_MOTIF_WM_HINTS, Xatom_MOTIF_DRAG_WINDOW,
+ Xatom_MOTIF_DRAG_TARGETS, Xatom_MOTIF_DRAG_AND_DROP_MESSAGE,
+ Xatom_MOTIF_DRAG_INITIATOR_INFO, Xatom_MOTIF_DRAG_RECEIVER_INFO;
+
+ Atom Xatom_XmTRANSFER_SUCCESS, Xatom_XmTRANSFER_FAILURE;
+
/* The frame (if any) which has the X window that has keyboard focus.
Zero if none. This is examined by Ffocus_frame in xfns.c. Note
that a mere EnterNotify event can set this; if you need to know the
@@ -547,7 +559,8 @@ struct x_display_info
Xatom_net_workarea, Xatom_net_wm_opaque_region, Xatom_net_wm_ping,
Xatom_net_wm_sync_request, Xatom_net_wm_sync_request_counter,
Xatom_net_wm_frame_drawn, Xatom_net_wm_user_time,
- Xatom_net_wm_user_time_window;
+ Xatom_net_wm_user_time_window, Xatom_net_client_list_stacking,
+ Xatom_net_wm_pid;
/* XSettings atoms and windows. */
Atom Xatom_xsettings_sel, Xatom_xsettings_prop, Xatom_xsettings_mgr;
@@ -602,6 +615,17 @@ struct x_display_info
int num_devices;
struct xi_device_t *devices;
+
+ Time pending_keystroke_time;
+ int pending_keystroke_source;
+
+#if defined USE_GTK && !defined HAVE_GTK3
+ /* This means the two variables above shouldn't be reset the first
+ time a KeyPress event arrives, since they were set from a raw key
+ press event that was sent before the first (real, not sent by an
+ input method) core key event. */
+ bool pending_keystroke_time_special_p;
+#endif
#endif
#ifdef HAVE_XKB
@@ -635,6 +659,20 @@ struct x_display_info
#ifdef HAVE_XINERAMA
bool xinerama_supported_p;
#endif
+
+#ifdef HAVE_XCOMPOSITE
+ bool composite_supported_p;
+ int composite_major;
+ int composite_minor;
+#endif
+
+#ifdef HAVE_XSHAPE
+ bool xshape_supported_p;
+ int xshape_major;
+ int xshape_minor;
+ int xshape_event_base;
+ int xshape_error_base;
+#endif
};
#ifdef HAVE_X_I18N
@@ -1352,8 +1390,6 @@ extern Lisp_Object x_cr_export_frames (Lisp_Object, cairo_surface_type_t);
#endif
#ifdef HAVE_XRENDER
-extern void x_xrender_color_from_gc_foreground (struct frame *, GC,
- XRenderColor *, bool);
extern void x_xrender_color_from_gc_background (struct frame *, GC,
XRenderColor *, bool);
extern void x_xr_ensure_picture (struct frame *f);
@@ -1365,10 +1401,12 @@ extern void x_xr_reset_ext_clip (struct frame *f);
extern void x_scroll_bar_configure (GdkEvent *);
#endif
-extern void x_display_set_last_user_time (struct x_display_info *, Time);
-
extern Lisp_Object x_dnd_begin_drag_and_drop (struct frame *, Time, Atom,
- bool);
+ Lisp_Object, Atom *, const char **,
+ size_t, bool);
+extern void x_dnd_do_unsupported_drop (struct x_display_info *, Lisp_Object,
+ Lisp_Object, Lisp_Object, Window, int,
+ int, Time);
extern void x_set_dnd_targets (Atom *, int);
INLINE int
@@ -1467,6 +1505,8 @@ extern void x_clipboard_manager_save_all (void);
extern Lisp_Object x_timestamp_for_selection (struct x_display_info *,
Lisp_Object);
+extern void x_set_pending_dnd_time (Time);
+extern void x_own_selection (Lisp_Object, Lisp_Object, Lisp_Object);
#ifdef USE_GTK
extern bool xg_set_icon (struct frame *, Lisp_Object);
@@ -1526,10 +1566,15 @@ extern void x_session_close (void);
extern struct input_event xg_pending_quit_event;
#endif
+extern bool x_dnd_in_progress;
+extern struct frame *x_dnd_frame;
+
#ifdef HAVE_XINPUT2
struct xi_device_t *xi_device_from_id (struct x_display_info *, int);
#endif
+extern void mark_xterm (void);
+
/* Is the frame embedded into another application? */
#define FRAME_X_EMBEDDED_P(f) (FRAME_X_OUTPUT(f)->explicit_parent != 0)
diff --git a/src/xwidget.c b/src/xwidget.c
index 71bc3504295..8bdfab02fd4 100644
--- a/src/xwidget.c
+++ b/src/xwidget.c
@@ -857,15 +857,34 @@ to_embedder (GdkWindow *window, double x, double y,
}
static GdkDevice *
-find_suitable_pointer (struct frame *f)
+find_suitable_pointer (struct frame *f, bool need_smooth)
{
GdkSeat *seat = gdk_display_get_default_seat
(gtk_widget_get_display (FRAME_GTK_WIDGET (f)));
+ GList *devices, *tem;
+ GdkDevice *device;
if (!seat)
return NULL;
- return gdk_seat_get_pointer (seat);
+ devices = gdk_seat_get_slaves (seat, GDK_SEAT_CAPABILITY_ALL_POINTING);
+ device = NULL;
+ tem = NULL;
+
+ if (need_smooth)
+ {
+ for (tem = devices; tem; tem = tem->next)
+ {
+ device = GDK_DEVICE (tem->data);
+
+ if (gdk_device_get_source (device) == GDK_SOURCE_TOUCHPAD)
+ break;
+ }
+ }
+
+ g_list_free (devices);
+
+ return !tem ? gdk_seat_get_pointer (seat) : device;
}
static GdkDevice *
@@ -1196,7 +1215,7 @@ xwidget_button_1 (struct xwidget_view *view,
xg_event->button.button = button;
xg_event->button.state = modifier_state;
xg_event->button.time = time;
- xg_event->button.device = find_suitable_pointer (view->frame);
+ xg_event->button.device = find_suitable_pointer (view->frame, false);
gtk_main_do_event (xg_event);
gdk_event_free (xg_event);
@@ -1242,7 +1261,8 @@ xwidget_button_1 (struct xwidget_view *view,
xg_event->crossing.detail = GDK_NOTIFY_ANCESTOR;
xg_event->crossing.mode = GDK_CROSSING_UNGRAB;
xg_event->crossing.window = g_object_ref (target_window);
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
gtk_main_do_event (xg_event);
gdk_event_free (xg_event);
@@ -1264,7 +1284,8 @@ xwidget_button_1 (struct xwidget_view *view,
xg_event->crossing.mode = GDK_CROSSING_UNGRAB;
xg_event->crossing.window = g_object_ref (toplevel);
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
gtk_main_do_event (xg_event);
gdk_event_free (xg_event);
}
@@ -1323,7 +1344,8 @@ xwidget_button (struct xwidget_view *view,
else
xg_event->scroll.direction = GDK_SCROLL_RIGHT;
- xg_event->scroll.device = find_suitable_pointer (view->frame);
+ xg_event->scroll.device = find_suitable_pointer (view->frame,
+ false);
xg_event->scroll.x = x;
xg_event->scroll.x_root = x;
@@ -1387,7 +1409,7 @@ xwidget_motion_notify (struct xwidget_view *view,
xg_event->motion.y_root = root_y;
xg_event->motion.time = time;
xg_event->motion.state = state;
- xg_event->motion.device = find_suitable_pointer (view->frame);
+ xg_event->motion.device = find_suitable_pointer (view->frame, false);
g_object_ref (xg_event->any.window);
@@ -1434,7 +1456,7 @@ xwidget_scroll (struct xwidget_view *view, double x, double y,
xg_event->scroll.state = state;
xg_event->scroll.delta_x = dx;
xg_event->scroll.delta_y = dy;
- xg_event->scroll.device = find_suitable_pointer (view->frame);
+ xg_event->scroll.device = find_suitable_pointer (view->frame, true);
xg_event->scroll.is_stop = stop_p;
g_object_ref (xg_event->any.window);
@@ -1499,7 +1521,7 @@ xwidget_pinch (struct xwidget_view *view, XIGesturePinchEvent *xev)
break;
}
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event, find_suitable_pointer (view->frame, false));
g_object_ref (xg_event->any.window);
gtk_main_do_event (xg_event);
@@ -1624,7 +1646,8 @@ xw_notify_virtual_upwards_until (struct xwidget_view *xv,
{
xg_event = gdk_event_new (type);
- gdk_event_set_device (xg_event, find_suitable_pointer (xv->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (xv->frame, false));
window_coords_from_toplevel (tem, toplevel, x, y, &cx, &cy);
xg_event->crossing.x = cx;
xg_event->crossing.y = cy;
@@ -1670,7 +1693,8 @@ xw_notify_virtual_downwards_until (struct xwidget_view *xv,
tem = it->data;
xg_event = gdk_event_new (type);
- gdk_event_set_device (xg_event, find_suitable_pointer (xv->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (xv->frame, false));
window_coords_from_toplevel (tem, toplevel, x, y, &cx, &cy);
xg_event->crossing.x = cx;
xg_event->crossing.y = cy;
@@ -1775,7 +1799,8 @@ xw_maybe_synthesize_crossing (struct xwidget_view *view,
xg_event->crossing.detail = GDK_NOTIFY_ANCESTOR;
xg_event->crossing.mode = exit_crossing;
xg_event->crossing.window = g_object_ref (view->last_crossing_window);
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
gtk_main_do_event (xg_event);
gdk_event_free (xg_event);
@@ -1839,7 +1864,8 @@ xw_maybe_synthesize_crossing (struct xwidget_view *view,
exit_crossing);
xg_event = gdk_event_new (GDK_LEAVE_NOTIFY);
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
window_coords_from_toplevel (last_crossing, toplevel,
x, y, &cx, &cy);
xg_event->crossing.x = cx;
@@ -1867,7 +1893,8 @@ xw_maybe_synthesize_crossing (struct xwidget_view *view,
entry_crossing);
xg_event = gdk_event_new (GDK_ENTER_NOTIFY);
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
window_coords_from_toplevel (current_window, toplevel,
x, y, &cx, &cy);
xg_event->crossing.x = cx;
@@ -1970,7 +1997,8 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event)
xg_event->motion.y_root = event->xmotion.y_root;
xg_event->motion.time = event->xmotion.time;
xg_event->motion.state = event->xmotion.state;
- xg_event->motion.device = find_suitable_pointer (view->frame);
+ xg_event->motion.device
+ = find_suitable_pointer (view->frame, false);
}
else
{
@@ -2017,7 +2045,8 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event)
return;
}
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
}
#endif
else
@@ -2046,7 +2075,8 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event)
xg_event->crossing.x_root = event->xcrossing.x_root;
xg_event->crossing.y_root = event->xcrossing.y_root;
xg_event->crossing.focus = event->xcrossing.focus;
- gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ gdk_event_set_device (xg_event,
+ find_suitable_pointer (view->frame, false));
}
gtk_main_do_event (xg_event);
@@ -2072,7 +2102,8 @@ synthesize_focus_in_event (GtkWidget *offscreen_window)
if (FRAME_WINDOW_P (SELECTED_FRAME ()))
gdk_event_set_device (focus_event,
- find_suitable_pointer (SELECTED_FRAME ()));
+ find_suitable_pointer (SELECTED_FRAME (),
+ false));
g_object_ref (wnd);
diff --git a/test/lisp/color-tests.el b/test/lisp/color-tests.el
index 49b632c8410..e4e1eda26d3 100644
--- a/test/lisp/color-tests.el
+++ b/test/lisp/color-tests.el
@@ -220,32 +220,32 @@
(ert-deftest color-tests-lighten-hsl ()
(should (equal (color-lighten-hsl 360 0.5 0.5 0) '(360 0.5 0.5)))
- (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.4)))
+ (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.45)))
(should (equal (color-lighten-hsl 360 0.5 0.5 -500) '(360 0.5 0.0)))
(should
(color-tests--approx-equal
- (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.85)))
+ (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.84)))
(should
(equal (color-lighten-hsl 120 0.5 0.8 500) '(120 0.5 1.0))))
(ert-deftest color-tests-lighten-name ()
- (should (equal (color-lighten-name "black" 100) "#ffffffffffff"))
+ (should (equal (color-lighten-name "black" 100) "#000000000000"))
(should (equal (color-lighten-name "white" 100) "#ffffffffffff"))
(should (equal (color-lighten-name "red" 0) "#ffff00000000"))
- (should (equal (color-lighten-name "red" 10) "#ffff33323332")))
+ (should (equal (color-lighten-name "red" 10) "#ffff19991999")))
(ert-deftest color-tests-darken-hsl ()
(should (equal (color-darken-hsl 360 0.5 0.5 0) '(360 0.5 0.5)))
- (should (equal (color-darken-hsl 360 0.5 0.5 -10) '(360 0.5 0.6)))
+ (should (equal (color-darken-hsl 360 0.5 0.5 -10) '(360 0.5 0.55)))
(should (equal (color-darken-hsl 360 0.5 0.5 -500) '(360 0.5 1.0)))
- (should (equal (color-darken-hsl 120 0.5 0.8 5) '(120 0.5 0.75)))
+ (should (equal (color-darken-hsl 120 0.5 0.8 5) '(120 0.5 0.76)))
(should (equal (color-darken-hsl 120 0.5 0.8 500) '(120 0.5 0.0))))
(ert-deftest color-tests-darken-name ()
(should (equal (color-darken-name "black" 100) "#000000000000"))
(should (equal (color-darken-name "white" 100) "#000000000000"))
(should (equal (color-darken-name "red" 0) "#ffff00000000"))
- (should (equal (color-darken-name "red" 10) "#cccc00000000")))
+ (should (equal (color-darken-name "red" 10) "#e66500000000")))
(provide 'color-tests)
;;; color-tests.el ends here
diff --git a/test/lisp/desktop-tests.el b/test/lisp/desktop-tests.el
new file mode 100644
index 00000000000..d52fe39ed96
--- /dev/null
+++ b/test/lisp/desktop-tests.el
@@ -0,0 +1,50 @@
+;;; desktop-tests.el --- Tests for desktop.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 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/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'desktop)
+
+(ert-deftest desktop-tests--emacs-pid-running-p ()
+ (should (desktop--emacs-pid-running-p (emacs-pid)))
+ (should-not (desktop--emacs-pid-running-p 1)))
+
+(ert-deftest desktop-tests--load-locked-desktop-p ()
+ (let ((desktop-load-locked-desktop t))
+ (should (desktop--load-locked-desktop-p (emacs-pid)))))
+
+(ert-deftest desktop-tests--load-locked-desktop-p-nil ()
+ (let ((desktop-load-locked-desktop nil))
+ (should-not (desktop--load-locked-desktop-p (emacs-pid)))))
+
+(ert-deftest desktop-tests--load-locked-desktop-p-ask ()
+ (let ((desktop-load-locked-desktop 'ask))
+ (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) t)))
+ (should (desktop--load-locked-desktop-p (emacs-pid))))
+ (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) nil)))
+ (should-not (desktop--load-locked-desktop-p (emacs-pid))))))
+
+(ert-deftest desktop-tests--load-locked-desktop-p-check ()
+ (let ((desktop-load-locked-desktop 'check-pid))
+ (desktop--load-locked-desktop-p (emacs-pid))))
+
+(provide 'desktop-tests)
diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el
index b5809ad0b77..e386342f6ee 100644
--- a/test/lisp/edmacro-tests.el
+++ b/test/lisp/edmacro-tests.el
@@ -25,23 +25,24 @@
(require 'edmacro)
(ert-deftest edmacro-test-edmacro-parse-keys ()
- (should (equal (edmacro-parse-keys "") ""))
- (should (equal (edmacro-parse-keys "x") "x"))
- (should (equal (edmacro-parse-keys "C-a") "\C-a"))
+ (should (equal (edmacro-parse-keys "") []))
+ (should (equal (edmacro-parse-keys "x") [?x]))
+ (should (equal (edmacro-parse-keys "C-a") [?\C-a]))
;; comments
- (should (equal (edmacro-parse-keys ";; foobar") ""))
- (should (equal (edmacro-parse-keys ";;;") ""))
- (should (equal (edmacro-parse-keys "; ; ;") ";;;"))
- (should (equal (edmacro-parse-keys "REM foobar") ""))
- (should (equal (edmacro-parse-keys "x ;; foobar") "x"))
- (should (equal (edmacro-parse-keys "x REM foobar") "x"))
+ (should (equal (edmacro-parse-keys ";; foobar") []))
+ (should (equal (edmacro-parse-keys ";;;") []))
+ (should (equal (edmacro-parse-keys "; ; ;") [?\; ?\; ?\;]))
+ (should (equal (edmacro-parse-keys "REM foobar") []))
+ (should (equal (edmacro-parse-keys "x ;; foobar") [?x]))
+ (should (equal (edmacro-parse-keys "x REM foobar") [?x]))
(should (equal (edmacro-parse-keys "<<goto-line>>")
- [134217848 103 111 116 111 45 108 105 110 101 13]))
+ [?\M-x ?g ?o ?t ?o ?- ?l ?i ?n ?e ?\r]))
;; repetitions
- (should (equal (edmacro-parse-keys "3*x") "xxx"))
- (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m"))
- (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo")))
+ (should (equal (edmacro-parse-keys "3*x") [?x ?x ?x]))
+ (should (equal (edmacro-parse-keys "3*C-m") [?\C-m ?\C-m ?\C-m]))
+ (should (equal (edmacro-parse-keys "10*foo")
+ (apply #'vconcat (make-list 10 [?f ?o ?o])))))
;;; edmacro-tests.el ends here
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el
new file mode 100644
index 00000000000..b6bdebc0a2b
--- /dev/null
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -0,0 +1,144 @@
+;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'oclosure)
+(require 'cl-lib)
+(require 'eieio)
+
+(oclosure-define (oclosure-test
+ (:copier oclosure-test-copy)
+ (:copier oclosure-test-copy1 (fst)))
+ "Simple OClosure."
+ fst snd (name :mutable t))
+
+(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
+
+(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod oclosure-test-gen ((_x oclosure))
+ (format "#<oclosure:%s>" (cl-call-next-method)))
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-test))
+ (format "#<oclosure-test:%s>" (cl-call-next-method)))
+
+(ert-deftest oclosure-test ()
+ (let* ((i 42)
+ (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi"))
+ ()
+ (list fst snd i)))
+ (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i)))
+ ()
+ (list fst snd 152 i))))
+ (should (equal (list (oclosure-test--fst ocl1)
+ (oclosure-test--snd ocl1)
+ (oclosure-test--name ocl1))
+ '(1 2 "hi")))
+ (should (equal (list (oclosure-test--fst ocl2)
+ (oclosure-test--snd ocl2)
+ (oclosure-test--name ocl2))
+ '(44 nil 43)))
+ (should (equal (funcall ocl1) '(1 2 44)))
+ (should (equal (funcall ocl2) '(44 nil 152 44)))
+ (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44)))
+ (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44)))
+ (should (cl-typep ocl1 'oclosure-test))
+ (should (cl-typep ocl1 'oclosure))
+ (should (member (oclosure-test-gen ocl1)
+ '("#<oclosure-test:#<oclosure:#<cons>>>"
+ "#<oclosure-test:#<oclosure:#<bytecode>>>")))
+ (should (stringp (documentation #'oclosure-test--fst)))
+ ))
+
+(ert-deftest oclosure-test-limits ()
+ (should
+ (condition-case err
+ (let ((lexical-binding t)
+ (byte-compile-debug t))
+ (byte-compile '(lambda ()
+ (let ((inc-fst nil))
+ (oclosure-lambda (oclosure-test (fst 'foo)) ()
+ (setq inc-fst (lambda () (setq fst (1+ fst))))
+ fst))))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "fst.*mutated" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand-all '(oclosure-define oclosure--foo a a))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot name: a$" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand-all
+ '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot name: fst$" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2))
+ () fst))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot: fst$" (cadr err)))))))
+
+(oclosure-define (oclosure-test-mut
+ (:parent oclosure-test)
+ (:copier oclosure-test-mut-copy))
+ "Simple OClosure with a mutable field."
+ (mut :mutable t))
+
+(ert-deftest oclosure-test-mutate ()
+ (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3))
+ (x)
+ (+ x fst mut)))
+ (f2 (oclosure-test-mut-copy f :fst 50)))
+ (should (equal (oclosure-test-mut--mut f) 3))
+ (should (equal (funcall f 5) 8))
+ (should (equal (funcall f2 5) 58))
+ (cl-incf (oclosure-test-mut--mut f) 7)
+ (should (equal (oclosure-test-mut--mut f) 10))
+ (should (equal (funcall f 5) 15))
+ (should (equal (funcall f2 15) 68))))
+
+(ert-deftest oclosure-test-slot-value ()
+ (require 'eieio)
+ (let ((ocl (oclosure-lambda
+ (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1))
+ (x)
+ (list name fst snd x))))
+ (should (equal 'fst1 (slot-value ocl 'fst)))
+ (should (equal 'snd1 (slot-value ocl 'snd)))
+ (should (equal 'name1 (slot-value ocl 'name)))
+ (setf (slot-value ocl 'name) 'new-name)
+ (should (equal 'new-name (slot-value ocl 'name)))
+ (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg)))
+ (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant)
+ (should (equal 'fst1 (slot-value ocl 'fst)))
+ ))
+
+;;; oclosure-tests.el ends here.
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 5603e764547..520f10dd4e6 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -21,7 +21,7 @@
;;; Code:
-(require 'ert)
+(require 'ert-x)
(require 'erc)
(require 'erc-ring)
(require 'erc-networks)
@@ -114,6 +114,63 @@
(should (get-buffer "#spam"))
(kill-buffer "#spam")))
+(ert-deftest erc--switch-to-buffer ()
+ (defvar erc-modified-channels-alist) ; lisp/erc/erc-track.el
+
+ (let ((proc (start-process "aNet" (current-buffer) "true"))
+ (erc-modified-channels-alist `(("fake") (,(messages-buffer))))
+ (inhibit-message noninteractive)
+ (completion-fail-discreetly t) ; otherwise ^G^G printed to .log file
+ ;;
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer (get-buffer-create "server")
+ (erc-mode)
+ (set-process-buffer (setq erc-server-process proc) (current-buffer))
+ (set-process-query-on-exit-flag erc-server-process nil)
+ (with-current-buffer (get-buffer-create "#chan")
+ (erc-mode)
+ (setq erc-server-process proc))
+ (with-current-buffer (get-buffer-create "#foo")
+ (erc-mode)
+ (setq erc-server-process proc))
+
+ (ert-info ("Channel #chan selectable from server buffer")
+ (ert-simulate-keys (list ?# ?c ?h ?a ?n ?\C-m)
+ (should (string= "#chan" (erc--switch-to-buffer))))))
+
+ (ert-info ("Channel #foo selectable from non-ERC buffer")
+ (ert-simulate-keys (list ?# ?f ?o ?o ?\C-m)
+ (should (string= "#foo" (erc--switch-to-buffer)))))
+
+ (ert-info ("Default selectable")
+ (ert-simulate-keys (list ?\C-m)
+ (should (string= "*Messages*" (erc--switch-to-buffer)))))
+
+ (ert-info ("Extant but non-ERC buffer not selectable")
+ (get-buffer-create "#fake") ; not ours
+ (ert-simulate-keys (kbd "#fake C-m C-a C-k C-m")
+ ;; Initial query fails ~~~~~~^; clearing input accepts default
+ (should (string= "*Messages*" (erc--switch-to-buffer)))))
+
+ (with-current-buffer (get-buffer-create "other")
+ (erc-mode)
+ (setq erc-server-process (start-process "bNet" (current-buffer) "true"))
+ (set-process-query-on-exit-flag erc-server-process nil))
+
+ (ert-info ("Foreign ERC buffer not selectable")
+ (ert-simulate-keys (kbd "other C-m C-a C-k C-m")
+ (with-current-buffer "server"
+ (should (string= "*Messages*" (erc--switch-to-buffer))))))
+
+ (ert-info ("Any ERC-buffer selectable from non-ERC buffer")
+ (should-not (eq major-mode 'erc-mode))
+ (ert-simulate-keys (list ?o ?t ?h ?e ?r ?\C-m)
+ (should (string= "other" (erc--switch-to-buffer)))))
+
+ (dolist (b '("server" "other" "#chan" "#foo" "#fake"))
+ (kill-buffer b))))
+
(ert-deftest erc-lurker-maybe-trim ()
(let (erc-lurker-trim-nicks
(erc-lurker-ignore-chars "_`"))
diff --git a/test/lisp/eshell/em-basic-tests.el b/test/lisp/eshell/em-basic-tests.el
new file mode 100644
index 00000000000..7a24f8b46c3
--- /dev/null
+++ b/test/lisp/eshell/em-basic-tests.el
@@ -0,0 +1,71 @@
+;;; em-basic-tests.el --- em-basic test suite -*- lexical-binding:t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for basic Eshell commands.
+
+;;; Code:
+
+(require 'ert)
+(require 'em-basic)
+
+(require 'eshell-tests-helpers
+ (expand-file-name "eshell-tests-helpers"
+ (file-name-directory (or load-file-name
+ default-directory))))
+
+;;; Tests:
+
+(ert-deftest em-basic-test/umask-print-numeric ()
+ "Test printing umask numerically."
+ (cl-letf (((symbol-function 'default-file-modes) (lambda () #o775)))
+ (should (equal (eshell-test-command-result "umask") "002\n")))
+ (cl-letf (((symbol-function 'default-file-modes) (lambda () #o654)))
+ (should (equal (eshell-test-command-result "umask") "123\n")))
+ ;; Make sure larger numbers don't cause problems.
+ (cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775)))
+ (should (equal (eshell-test-command-result "umask") "002\n"))))
+
+(ert-deftest em-basic-test/umask-read-symbolic ()
+ "Test printing umask symbolically."
+ (cl-letf (((symbol-function 'default-file-modes) (lambda () #o775)))
+ (should (equal (eshell-test-command-result "umask -S")
+ "u=rwx,g=rwx,o=rx\n")))
+ (cl-letf (((symbol-function 'default-file-modes) (lambda () #o654)))
+ (should (equal (eshell-test-command-result "umask -S")
+ "u=wx,g=rx,o=x\n")))
+ ;; Make sure larger numbers don't cause problems.
+ (cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775)))
+ (should (equal (eshell-test-command-result "umask -S")
+ "u=rwx,g=rwx,o=rx\n"))))
+
+(ert-deftest em-basic-test/umask-set ()
+ "Test setting umask."
+ (let ((file-modes 0))
+ (cl-letf (((symbol-function 'set-default-file-modes)
+ (lambda (mode) (setq file-modes mode))))
+ (eshell-test-command-result "umask 002")
+ (should (= file-modes #o775))
+ (eshell-test-command-result "umask 123")
+ (should (= file-modes #o654))
+ (eshell-test-command-result "umask $(identity #o222)")
+ (should (= file-modes #o555)))))
+
+;; em-basic-tests.el ends here
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index e31db07c619..bcc2dc320b2 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -44,6 +44,10 @@
"Test `eshell-command-result' with an elisp command."
(should (equal (eshell-test-command-result "(+ 1 2)") 3)))
+(ert-deftest eshell-test/lisp-command-with-quote ()
+ "Test `eshell-command-result' with an elisp command containing a quote."
+ (should (equal (eshell-test-command-result "(eq 'foo nil)") nil)))
+
(ert-deftest eshell-test/for-loop ()
"Test `eshell-command-result' with a for loop.."
(let ((process-environment (cons "foo" process-environment)))
@@ -144,9 +148,9 @@ chars"
"Test that the backslash is not preserved for escaped special
chars"
(with-temp-eshell
- (eshell-command-result-p "echo \"h\\\\i\""
+ (eshell-command-result-p "echo \"\\\"hi\\\\\""
;; Backslashes are doubled for regexp.
- "h\\\\i\n")))
+ "\\\"hi\\\\\n")))
(ert-deftest eshell-test/command-running-p ()
"Modeline should show no command running"
diff --git a/test/lisp/files-x-tests.el b/test/lisp/files-x-tests.el
index 60787e1cd3d..7ee2f0c1a65 100644
--- a/test/lisp/files-x-tests.el
+++ b/test/lisp/files-x-tests.el
@@ -325,6 +325,9 @@
(should-not (boundp 'remote-shell-file-name))
(should (string-equal (symbol-value 'remote-null-device) "null"))
+ (connection-local-set-profiles
+ files-x-test--application 'remote-bash)
+
(with-connection-local-variables
;; All connection-local variables are set. They apply in
;; reverse order in `connection-local-variables-alist'.
@@ -347,6 +350,21 @@
(should
(string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh"))
(should
+ (string-equal (symbol-value 'remote-null-device) "/dev/null"))
+
+ ;; Run another instance of `with-connection-local-variables'
+ ;; with a different application.
+ (let ((connection-local-default-application (cadr files-x-test--application)))
+ (with-connection-local-variables
+ ;; The proper variable values are set.
+ (should
+ (string-equal (symbol-value 'remote-shell-file-name) "/bin/bash"))
+ (should
+ (string-equal (symbol-value 'remote-null-device) "/dev/null"))))
+ ;; The variable values are reset.
+ (should
+ (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh"))
+ (should
(string-equal (symbol-value 'remote-null-device) "/dev/null")))
;; Everything is rewound. The old variable values are reset.
diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el
new file mode 100644
index 00000000000..888351addac
--- /dev/null
+++ b/test/lisp/hl-line-tests.el
@@ -0,0 +1,114 @@
+;;; hl-line-tests.el --- Test suite for hl-line. -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+(require 'ert)
+(require 'hl-line)
+
+(defsubst hl-line-tests-verify (_label on-p)
+ (if on-p
+ (cl-some (apply-partially #'eq hl-line-overlay)
+ (overlays-at (point)))
+ (not (cl-some (apply-partially #'eq hl-line-overlay)
+ (overlays-at (point))))))
+
+(ert-deftest hl-line-tests-sticky-across-frames ()
+ (skip-unless (display-graphic-p))
+ (customize-set-variable 'global-hl-line-sticky-flag t)
+ (call-interactively #'global-hl-line-mode)
+ (let ((first-frame (selected-frame))
+ (first-buffer "foo")
+ (second-buffer "bar")
+ second-frame)
+ (unwind-protect
+ (progn
+ (switch-to-buffer first-buffer)
+ (save-excursion
+ (insert (buffer-name)))
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 111 t))
+ (select-frame (setq second-frame (make-frame)))
+ (switch-to-buffer second-buffer)
+ (save-excursion
+ (insert (buffer-name)))
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 762 t))
+ (with-current-buffer first-buffer
+ (should (hl-line-tests-verify 534 t)))
+ (call-interactively #'global-hl-line-mode)
+ (should (hl-line-tests-verify 125 nil))
+ (with-current-buffer first-buffer
+ (should (hl-line-tests-verify 892 nil)))
+
+ ;; now do unsticky
+ (customize-set-variable 'hl-line-sticky-flag nil)
+ (call-interactively #'global-hl-line-mode)
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 467 t))
+ (with-current-buffer first-buffer
+ (should (hl-line-tests-verify 765 nil)))
+ (select-frame first-frame)
+ (should (equal (buffer-name) first-buffer))
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 423 t))
+ (with-current-buffer second-buffer
+ (should (hl-line-tests-verify 897 nil))))
+ (let (kill-buffer-query-functions)
+ (ignore-errors (kill-buffer first-buffer))
+ (ignore-errors (kill-buffer second-buffer))
+ (ignore-errors (delete-frame second-frame))))))
+
+(ert-deftest hl-line-tests-sticky ()
+ (customize-set-variable 'hl-line-sticky-flag t)
+ (let ((first-buffer "foo")
+ (second-buffer "bar"))
+ (unwind-protect
+ (progn
+ (switch-to-buffer first-buffer)
+ (hl-line-mode 1)
+ (save-excursion
+ (insert (buffer-name)))
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 123 t))
+ (switch-to-buffer second-buffer)
+ (hl-line-mode 1)
+ (save-excursion
+ (insert (buffer-name)))
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 56 t))
+ (with-current-buffer first-buffer
+ (should (hl-line-tests-verify 67 t)))
+
+ ;; now do unsticky
+ (customize-set-variable 'hl-line-sticky-flag nil)
+ (should (hl-line-tests-verify 234 t))
+ (with-current-buffer first-buffer
+ (should (hl-line-tests-verify 231 nil)))
+ (switch-to-buffer first-buffer)
+ (run-hooks 'post-command-hook)
+ (should (hl-line-tests-verify 257 t))
+ (with-current-buffer second-buffer
+ (should (hl-line-tests-verify 999 nil)))))
+ (let (kill-buffer-query-functions)
+ (ignore-errors (kill-buffer first-buffer))
+ (ignore-errors (kill-buffer second-buffer)))))
+
+(provide 'hl-line-tests)
+
+;;; hl-line-tests.el ends here
diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el
index 6abfcfedcf4..2b3e818d720 100644
--- a/test/lisp/image-tests.el
+++ b/test/lisp/image-tests.el
@@ -75,9 +75,10 @@
(should-not (find-image '((:type png :file "does-not-exist-foo-bar.png")))))
(ert-deftest image-type-from-file-name ()
- (should (eq (image-type-from-file-name "foo.jpg") 'jpeg))
- (should (eq (image-type-from-file-name "foo.png") 'png))
- (should (eq (image-type-from-file-name "foo.webp") 'webp)))
+ (with-suppressed-warnings ((obsolete image-type-from-file-name))
+ (should (eq (image-type-from-file-name "foo.jpg") 'jpeg))
+ (should (eq (image-type-from-file-name "foo.png") 'png))
+ (should (eq (image-type-from-file-name "foo.webp") 'webp))))
(ert-deftest image-type/from-filename ()
;; On emba, `image-types' and `image-load-path' do not exist.
diff --git a/test/lisp/international/textsec-tests.el b/test/lisp/international/textsec-tests.el
index 5bf9a3dcfb3..6b0773dc407 100644
--- a/test/lisp/international/textsec-tests.el
+++ b/test/lisp/international/textsec-tests.el
@@ -117,7 +117,19 @@
(should (textsec-domain-suspicious-p "f\N{LEFT-TO-RIGHT ISOLATE}oo.org"))
(should (textsec-domain-suspicious-p "Сгсе.ru"))
- (should-not (textsec-domain-suspicious-p "фСгсе.ru")))
+ (should-not (textsec-domain-suspicious-p "фСгсе.ru"))
+
+ (should-not (textsec-domain-suspicious-p
+ "21a:34aa:c782:3ad2:1bf8:73f8:141:66e8"))
+ (should (textsec-domain-suspicious-p
+ "21a:34aa:c782:3ad2:1bf8:73f8:141:66e8:66e8"))
+ (should-not (textsec-domain-suspicious-p
+ "[21a:34aa:c782:3ad2:1bf8:73f8:141:66e8]"))
+ (should (textsec-domain-suspicious-p
+ "[21a:34aa:c782:3ad2:1bf8:73f8:141:66e8"))
+ (should-not (textsec-domain-suspicious-p "138.25.106.12"))
+ (should-not (textsec-domain-suspicious-p "2001:db8::ff00:42:8329"))
+ (should-not (textsec-domain-suspicious-p "::ffff:129.55.2.201")))
(ert-deftest test-suspicious-local ()
(should-not (textsec-local-address-suspicious-p "larsi"))
diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el
index c62a2a501ba..75d700070aa 100644
--- a/test/lisp/kmacro-tests.el
+++ b/test/lisp/kmacro-tests.el
@@ -580,8 +580,10 @@ This is a regression test for: Bug#3412, Bug#11817."
;; Check the bound key and run it and verify correct counter
;; and format.
(should (equal (string-to-vector "\C-cxi")
- (car (kmacro-extract-lambda
- (key-binding "\C-x\C-kA")))))
+ (car (with-suppressed-warnings
+ ((obsolete kmacro-extract-lambda))
+ (kmacro-extract-lambda
+ (key-binding "\C-x\C-kA"))))))
(kmacro-tests-should-insert "<5>"
(funcall (key-binding "\C-x\C-kA")))))
@@ -605,7 +607,7 @@ This is a regression test for: Bug#3412, Bug#11817."
(dotimes (i 2)
(kmacro-tests-define-macro (make-vector (1+ i) (+ ?a i)))
(kmacro-name-last-macro 'kmacro-tests-symbol-for-test)
- (should (fboundp 'kmacro-tests-symbol-for-test)))
+ (should (commandp 'kmacro-tests-symbol-for-test)))
;; Now run the function bound to the symbol. Result should be the
;; second macro.
@@ -822,6 +824,15 @@ This is a regression for item 7 in Bug#24991."
:macro-result "x")
(kmacro-tests-simulate-command '(beginning-of-line))))
+(ert-deftest kmacro-tests--cl-print ()
+ (should (equal (cl-prin1-to-string
+ (kmacro [?a ?b backspace backspace]))
+ "#f(kmacro \"a b <backspace> <backspace>\")"))
+ (should (equal (cl-prin1-to-string
+ (with-suppressed-warnings ((obsolete kmacro-lambda-form))
+ (kmacro-lambda-form [?a ?b backspace backspace] 1 "%d")))
+ "#f(kmacro \"a b <backspace> <backspace>\" 1 \"%d\")")))
+
(cl-defun kmacro-tests-run-step-edit
(macro &key events sequences result macro-result)
"Set up and run a test of `kmacro-step-edit-macro'.
diff --git a/test/lisp/mail/undigest-tests.el b/test/lisp/mail/undigest-tests.el
new file mode 100644
index 00000000000..5ad0da0fc09
--- /dev/null
+++ b/test/lisp/mail/undigest-tests.el
@@ -0,0 +1,354 @@
+;;; undigest-tests.el --- Tests for undigest.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'rmail)
+(require 'undigest)
+
+;;; Variables:
+;; Some digests for testing.
+(defvar rmail-rfc934-digest "From tester Fri Jan 24 00:00:00 2022
+From: Digester <digester@digester.com>
+To: Undigester <undigester@undigester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Testing you
+
+Testing the undigester.
+
+------- Message sep
+
+From: NN1 <nn1@nn1.com>
+To: Digester <digester@digester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Message one
+
+This is message one.
+
+------- Message sep
+
+From: NN2 <nn2@nn2.com>
+To: Digester <digester@digester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Message two
+
+This is message two.
+"
+
+ "RFC 934 digest.")
+
+(defvar rmail-rfc1153-digest-strict "From tester Fri Jan 24 00:00:00 2022
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: Digester <digester@digester.com>
+To: Undigester <undigester@undigester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Testing you
+
+Some mailing list information.
+
+Today's Topics:
+
+ 1. Message One Subject (Sender)
+ 2. Message Two Subject (Sender)
+
+----------------------------------------------------------------------
+
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: NN1 <nn1@nn1.com>
+Subject: Message One Subject
+
+This is message one.
+
+------------------------------
+
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: NN2 <nn2@nn2.com>
+Subject: Message Two Subject
+
+This is message two.
+
+------------------------------
+
+End of Digest.
+************************************
+"
+ "RFC 1153 strict style digest.")
+
+(defvar rmail-rfc1153-digest-less-strict "From tester Fri Jan 24 00:00:00 2022
+From: Digester <digester@digester.com>
+To: Undigester <undigester@undigester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Testing you
+
+Some mailing list information.
+
+Today's Topics:
+
+ 1. Message One Subject (Sender)
+ 2. Message Two Subject (Sender)
+
+----------------------------------------------------------------------
+
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: NN1 <nn1@nn1.com>
+Subject: Message One Subject
+
+This is message one.
+
+------------------------------
+
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: NN2 <nn2@nn2.com>
+Subject: Message Two Subject
+
+This is message two.
+
+------------------------------
+
+Subject: Digest Footer
+
+End of Sbcl-help Digest, Vol 158, Issue 4
+*****************************************
+"
+ "RFC 1153 style digest, with a Subject header.")
+
+(defvar rmail-rfc1153-digest-sloppy "From tester Fri Jan 24 00:00:00 2022
+From: Digester <digester@digester.com>
+To: Undigester <undigester@undigester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Testing you
+
+Some mailing list information.
+
+Today's Topics:
+
+ 1. Message One Subject (Sender)
+ 2. Message Two Subject (Sender)
+
+----------------------------------------------------------------------
+
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: NN1 <nn1@nn1.com>
+Subject: Message One Subject
+
+This is message one.
+
+------------------------------
+
+Date: ddd, dd mmm yy hh:mm:ss zzz
+From: NN2 <nn2@nn2.com>
+Subject: Message Two Subject
+
+This is message two.
+
+------------------------------
+
+Subject: Digest Footer
+
+______________________________________________
+Some blurb.
+
+End of Digest.
+************************************
+"
+ "RFC 1153 sloppy style digest.")
+
+(defvar rmail-rfc1521-mime-digest "From tester Fri Jan 24 00:00:00 2022
+From: Digester <digester@digester.com>
+To: Undigester <undigester@undigester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Test digest
+MIME-Version: 1.0
+Content-Type: multipart/digest; boundary=\"----- =_aaaaaaaaaa0\"
+
+------- =_aaaaaaaaaa0
+Content-Type: message/rfc822
+
+From: NN1 <nn1@nn1.com>
+To: Digester <digester@digester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Message one
+
+Message one.
+
+------- =_aaaaaaaaaa0
+
+From: NN2 <nn2@nn2.com>
+To: Digester <digester@digester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Message two
+
+Message two.
+
+------- =_aaaaaaaaaa0
+"
+ "RFC 1521 style MIME digest.")
+
+(defvar rmail-multipart-mixed-digest
+ "From tester Fri Jan 24 00:00:00 2022
+From: Digester <digester@digester.com>
+To: Undigester <undigester@undigester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Test digest
+Content-Type: multipart/mixed; boundary=\"===============2529375068597856000==\"
+MIME-Version: 1.0
+
+--===============2529375068597856000==
+Content-Type: text/plain;
+MIME-Version: 1.0
+Content-Description: Today's Topics
+
+Some message.
+
+--===============2529375068597856000==
+Content-Type: multipart/digest; boundary=\"===============6060050777038710134==\"
+MIME-Version: 1.0
+
+--===============6060050777038710134==
+Content-Type: message/rfc822
+MIME-Version: 1.0
+
+From: NN1 <nn1@nn1.com>
+To: Digester <digester@digester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Message one
+
+Message one.
+
+--===============6060050777038710134==
+Content-Type: message/rfc822
+MIME-Version: 1.0
+
+From: NN2 <nn2@nn2.com>
+To: Digester <digester@digester.com>
+Date: ddd, dd mmm yy hh:mm:ss zzz
+Subject: Message two
+
+Message two.
+
+--===============6060050777038710134==--
+
+--===============2529375068597856000==
+Content-Type: text/plain;
+MIME-Version: 1.0
+Content-Description: Digest Footer
+
+The footer.
+
+--===============2529375068597856000==--"
+ "RFC 1521 digest inside a multipart/mixed message.")
+
+;;; Utils:
+(defun rmail-message-content (message)
+ "Return the content of the message numbered MESSAGE."
+ (rmail-show-message message)
+ (let ((beg (rmail-msgbeg rmail-current-message))
+ (end (rmail-msgend rmail-current-message)))
+ (with-current-buffer rmail-view-buffer
+ (save-excursion
+ (goto-char beg)
+ (search-forward "\n\n" end nil)
+ (buffer-substring-no-properties (match-end 0) end)))))
+
+;;; Tests:
+(ert-deftest rmail-undigest-test-rfc934-digest ()
+ "Test that we can undigest a RFC 934 digest."
+ (let ((file (make-temp-file "undigest-test-")))
+ (with-temp-file file
+ (insert rmail-rfc934-digest)
+ (write-region nil nil file)
+ (rmail file)
+ (undigestify-rmail-message)
+ (should (= rmail-total-messages 4))
+ (should (string= (rmail-message-content 2) "Testing the undigester.\n\n"))
+ (should (string= (rmail-message-content 3) "This is message one.\n\n"))
+ (should (string= (rmail-message-content 4) "This is message two.\n")))))
+
+(ert-deftest rmail-undigest-test-rfc1153-digest-strict ()
+ "Test that we can undigest a strict RFC 1153 digest."
+ :expected-result :failed
+ (let ((file (make-temp-file "undigest-test-")))
+ (with-temp-file file
+ (insert rmail-rfc1153-digest-strict)
+ (write-region nil nil file)
+ (rmail file)
+ (should
+ (condition-case nil
+ (progn
+ ;; This throws an error, because the Trailer is not recognized
+ ;; as a valid RFC 822 (or later) message.
+ (undigestify-rmail-message)
+ (should (string= (rmail-message-content 2) "Testing the undigester.\n\n"))
+ (should (string= (rmail-message-content 3) "This is message one.\n\n"))
+ (should (string= (rmail-message-content 4) "This is message two.\n"))
+ t)
+ (error nil))))))
+
+(ert-deftest rmail-undigest-test-rfc1153-less-strict-digest ()
+ "Test that we can undigest a RFC 1153 with a Subject header in its footer."
+ (let ((file (make-temp-file "undigest-test-")))
+ (with-temp-file file
+ (insert rmail-rfc1153-digest-less-strict)
+ (write-region nil nil file)
+ (rmail file)
+ (undigestify-rmail-message)
+ (should (= rmail-total-messages 5))
+ (should (string= (rmail-message-content 3) "This is message one.\n\n"))
+ (should (string= (rmail-message-content 4) "This is message two.\n\n")))))
+
+(ert-deftest rmail-undigest-test-rfc1153-sloppy-digest ()
+ "Test that we can undigest a sloppy RFC 1153 digest."
+ (let ((file (make-temp-file "undigest-test-")))
+ (with-temp-file file
+ (insert rmail-rfc1153-digest-sloppy)
+ (write-region nil nil file)
+ (rmail file)
+ (undigestify-rmail-message)
+ (should (= rmail-total-messages 5))
+ (should (string= (rmail-message-content 3) "This is message one.\n\n"))
+ (should (string= (rmail-message-content 4) "This is message two.\n\n")))))
+
+;; This fails because `rmail-digest-parse-mime' combines the preamble with the
+;; first message of the digest. And then, it doesn't get rid of the last
+;; separator.
+(ert-deftest rmail-undigest-test-rfc1521-mime-digest ()
+ "Test that we can undigest a RFC 1521 MIME digest."
+ :expected-result :failed
+ (let ((file (make-temp-file "undigest-test-")))
+ (with-temp-file file
+ (insert rmail-rfc1521-mime-digest)
+ (write-region nil nil file)
+ (rmail file)
+ (undigestify-rmail-message)
+ (should (= rmail-total-messages 3))
+ (should (string= (rmail-message-content 2) "Message one.\n\n"))
+ (should (string= (rmail-message-content 3) "Message two.\n\n")))))
+
+(ert-deftest rmail-undigest-test-multipart-mixed-digest ()
+ "Test that we can undigest a digest inside a multipart/mixed digest."
+ (let ((file (make-temp-file "undigest-test-")))
+ (with-temp-file file
+ (insert rmail-multipart-mixed-digest)
+ (write-region nil nil file)
+ (rmail file)
+ (undigestify-rmail-message)
+ (should (= rmail-total-messages 4))
+ (should (string= (rmail-message-content 2) "Message one.\n\n"))
+ (should (string= (rmail-message-content 3) "Message two.\n\n")))))
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index f34fdbdaf79..e9ea758956a 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4540,14 +4540,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((default-directory tramp-test-temporary-file-directory)
(tmp-name (tramp--test-make-temp-name nil quoted))
- kill-buffer-query-functions proc)
+ kill-buffer-query-functions command proc)
;; Simple process.
(unwind-protect
(with-temp-buffer
- (setq proc (start-file-process "test1" (current-buffer) "cat"))
+ (setq command '("cat")
+ proc
+ (apply #'start-file-process "test1" (current-buffer) command))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\n")
(process-send-eof proc)
;; Read output.
@@ -4564,11 +4567,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(with-temp-buffer
(write-region "foo" nil tmp-name)
(should (file-exists-p tmp-name))
- (setq proc
- (start-file-process
- "test2" (current-buffer)
- "cat" (file-name-nondirectory tmp-name)))
+ (setq command `("cat" ,(file-name-nondirectory tmp-name))
+ proc
+ (apply #'start-file-process "test2" (current-buffer) command))
(should (processp proc))
+ (should (equal (process-get proc 'remote-command) command))
;; Read output.
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
@@ -4583,9 +4586,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Process filter.
(unwind-protect
(with-temp-buffer
- (setq proc (start-file-process "test3" (current-buffer) "cat"))
+ (setq command '("cat")
+ proc
+ (apply #'start-file-process "test3" (current-buffer) command))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(set-process-filter
proc
(lambda (p s) (with-current-buffer (process-buffer p) (insert s))))
@@ -4604,9 +4610,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(unless (tramp--test-sshfs-p)
(unwind-protect
(with-temp-buffer
- (setq proc (start-file-process "test3" (current-buffer) "cat"))
+ (setq command '("cat")
+ proc
+ (apply #'start-file-process "test4" (current-buffer) command))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(set-process-filter proc t)
(process-send-string proc "foo\n")
(process-send-eof proc)
@@ -4632,12 +4641,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(dolist (process-connection-type '(nil pipe t pty))
(unwind-protect
(with-temp-buffer
- (setq proc
- (start-file-process
- (format "test4-%s" process-connection-type)
- (current-buffer) "hexdump" "-v" "-e" "/1 \"%02X\n\""))
+ (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"")
+ proc
+ (apply #'start-file-process
+ (format "test5-%s" process-connection-type)
+ (current-buffer) command))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\r\n")
(process-send-eof proc)
;; Read output.
@@ -4665,12 +4676,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; It works only for tramp-sh.el, and not direct async processes.
(if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p))
(should-error
- (start-file-process "test5" (current-buffer) nil)
+ (start-file-process "test6" (current-buffer) nil)
:type 'wrong-type-argument)
- (setq proc (start-file-process "test5" (current-buffer) nil))
+ (setq proc (start-file-process "test6" (current-buffer) nil))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should-not (process-get proc 'remote-command))
;; On MS Windows, `process-tty-name' returns nil.
(unless (tramp--test-windows-nt-p)
(should (stringp (process-tty-name proc))))))
@@ -4724,19 +4736,21 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((default-directory tramp-test-temporary-file-directory)
(tmp-name (tramp--test-make-temp-name nil quoted))
- kill-buffer-query-functions proc)
+ kill-buffer-query-functions command proc)
(with-no-warnings (should-not (make-process)))
;; Simple process.
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("cat")
+ proc
(with-no-warnings
(make-process
- :name "test1" :buffer (current-buffer) :command '("cat")
+ :name "test1" :buffer (current-buffer) :command command
:file-handler t)))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\n")
(process-send-eof proc)
;; Read output.
@@ -4753,13 +4767,14 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(write-region "foo" nil tmp-name)
(should (file-exists-p tmp-name))
- (setq proc
+ (setq command `("cat" ,(file-name-nondirectory tmp-name))
+ proc
(with-no-warnings
(make-process
- :name "test2" :buffer (current-buffer)
- :command `("cat" ,(file-name-nondirectory tmp-name))
+ :name "test2" :buffer (current-buffer) :command command
:file-handler t)))
(should (processp proc))
+ (should (equal (process-get proc 'remote-command) command))
;; Read output.
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
@@ -4774,16 +4789,18 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Process filter.
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("cat")
+ proc
(with-no-warnings
(make-process
- :name "test3" :buffer (current-buffer) :command '("cat")
+ :name "test3" :buffer (current-buffer) :command command
:filter
(lambda (p s)
(with-current-buffer (process-buffer p) (insert s)))
:file-handler t)))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\n")
(process-send-eof proc)
;; Read output.
@@ -4799,14 +4816,16 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(unless (tramp--test-sshfs-p)
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("cat")
+ proc
(with-no-warnings
(make-process
- :name "test3" :buffer (current-buffer) :command '("cat")
+ :name "test4" :buffer (current-buffer) :command command
:filter t
:file-handler t)))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\n")
(process-send-eof proc)
;; Read output. There shouldn't be any.
@@ -4822,16 +4841,18 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Process sentinel.
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("cat")
+ proc
(with-no-warnings
(make-process
- :name "test4" :buffer (current-buffer) :command '("cat")
+ :name "test5" :buffer (current-buffer) :command command
:sentinel
(lambda (p s)
(with-current-buffer (process-buffer p) (insert s)))
:file-handler t)))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\n")
(process-send-eof proc)
(delete-process proc)
@@ -4850,14 +4871,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(let ((stderr (generate-new-buffer "*stderr*")))
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("cat" "/does-not-exist")
+ proc
(with-no-warnings
(make-process
- :name "test5" :buffer (current-buffer)
- :command '("cat" "/does-not-exist")
+ :name "test6" :buffer (current-buffer) :command command
:stderr stderr
:file-handler t)))
(should (processp proc))
+ (should (equal (process-get proc 'remote-command) command))
;; Read output.
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc 0 nil t)))
@@ -4881,14 +4903,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(unless (tramp-direct-async-process-p)
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("cat" "/does-not-exist")
+ proc
(with-no-warnings
(make-process
- :name "test6" :buffer (current-buffer)
- :command '("cat" "/does-not-exist")
+ :name "test7" :buffer (current-buffer) :command command
:stderr tmp-name
:file-handler t)))
(should (processp proc))
+ (should (equal (process-get proc 'remote-command) command))
;; Read stderr.
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc nil nil t)))
@@ -4919,18 +4942,20 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(unless connection-type '(nil pipe t pty)))
(unwind-protect
(with-temp-buffer
- (setq proc
+ (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"")
+ proc
(with-no-warnings
(make-process
:name
- (format "test7-%s-%s"
+ (format "test8-%s-%s"
connection-type process-connection-type)
:buffer (current-buffer)
:connection-type connection-type
- :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"")
+ :command command
:file-handler t)))
(should (processp proc))
(should (equal (process-status proc) 'run))
+ (should (equal (process-get proc 'remote-command) command))
(process-send-string proc "foo\r\n")
(process-send-eof proc)
;; Read output.
@@ -4959,6 +4984,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(ert-deftest tramp-test31-interrupt-process ()
"Check `interrupt-process'."
:tags (append '(:expensive-test :tramp-asynchronous-processes)
+ ;; The final `process-live-p' check does not run sufficiently.
(and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
'(:unstable)))
(skip-unless (tramp--test-enabled))
@@ -4970,16 +4996,19 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; process.
(let ((default-directory (file-truename tramp-test-temporary-file-directory))
(delete-exited-processes t)
- kill-buffer-query-functions proc)
+ kill-buffer-query-functions command proc)
(unwind-protect
(with-temp-buffer
- (setq proc (start-file-process-shell-command
- "test" (current-buffer)
- "trap 'echo boom; exit 1' 2; sleep 100"))
+ (setq command "trap 'echo boom; exit 1' 2; sleep 100"
+ proc (start-file-process-shell-command
+ "test" (current-buffer) command))
(should (processp proc))
(should (process-live-p proc))
(should (equal (process-status proc) 'run))
(should (numberp (process-get proc 'remote-pid)))
+ (should (equal (process-get proc 'remote-command)
+ (with-connection-local-variables
+ `(,shell-file-name ,shell-command-switch ,command))))
(should (interrupt-process proc))
;; Let the process accept the interrupt.
(with-timeout (10 (tramp--test-timeout-handler))
@@ -4994,12 +5023,127 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Cleanup.
(ignore-errors (delete-process proc)))))
+(ert-deftest tramp-test31-signal-process ()
+ "Check `signal-process'."
+ :tags (append '(:expensive-test :tramp-asynchronous-processes)
+ ;; The final `process-live-p' check does not run sufficiently.
+ (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
+ '(:unstable)))
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-crypt-p)))
+ ;; Since Emacs 29.1.
+ (skip-unless (boundp 'signal-process-functions))
+
+ ;; We must use `file-truename' for the temporary directory, in
+ ;; order to establish the connection prior running an asynchronous
+ ;; process.
+ (let ((default-directory (file-truename tramp-test-temporary-file-directory))
+ (delete-exited-processes t)
+ kill-buffer-query-functions command proc)
+
+ (dolist (sigcode '(2 INT))
+ (unwind-protect
+ (with-temp-buffer
+ (setq command "trap 'echo boom; exit 1' 2; sleep 100"
+ proc (start-file-process-shell-command
+ (format "test1%s" sigcode) (current-buffer) command))
+ (should (processp proc))
+ (should (process-live-p proc))
+ (should (equal (process-status proc) 'run))
+ (should (numberp (process-get proc 'remote-pid)))
+ (should (equal (process-get proc 'remote-command)
+ (with-connection-local-variables
+ `(,shell-file-name ,shell-command-switch ,command))))
+ (should (zerop (signal-process proc sigcode)))
+ ;; Let the process accept the signal.
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (accept-process-output proc 0 nil t)))
+ (should-not (process-live-p proc)))
+
+ ;; Cleanup.
+ (ignore-errors (kill-process proc))
+ (ignore-errors (delete-process proc)))
+
+ (unwind-protect
+ (with-temp-buffer
+ (setq command "trap 'echo boom; exit 1' 2; sleep 100"
+ proc (start-file-process-shell-command
+ (format "test2%s" sigcode) (current-buffer) command))
+ (should (processp proc))
+ (should (process-live-p proc))
+ (should (equal (process-status proc) 'run))
+ (should (numberp (process-get proc 'remote-pid)))
+ (should (equal (process-get proc 'remote-command)
+ (with-connection-local-variables
+ `(,shell-file-name ,shell-command-switch ,command))))
+ (should
+ (zerop
+ (signal-process
+ (process-get proc 'remote-pid) sigcode default-directory)))
+ ;; Let the process accept the signal.
+ (with-timeout (10 (tramp--test-timeout-handler))
+ (while (accept-process-output proc 0 nil t)))
+ (should-not (process-live-p proc)))
+
+ ;; Cleanup.
+ (ignore-errors (kill-process proc))
+ (ignore-errors (delete-process proc))))))
+
+(ert-deftest tramp-test31-list-system-processes ()
+ "Check `list-system-processes'."
+ :tags '(:expensive-test)
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-supports-processes-p))
+ ;; `list-system-processes' is supported since Emacs 29.1.
+ (skip-unless (tramp--test-emacs29-p))
+
+ (let ((default-directory tramp-test-temporary-file-directory))
+ (skip-unless (consp (list-system-processes)))
+ (should (not (equal (list-system-processes)
+ (let ((default-directory temporary-file-directory))
+ (list-system-processes)))))))
+
+(ert-deftest tramp-test31-process-attributes ()
+ "Check `process-attributes'."
+ :tags '(:expensive-test :tramp-asynchronous-processes)
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-supports-processes-p))
+ ;; `process-attributes' is supported since Emacs 29.1.
+ (skip-unless (tramp--test-emacs29-p))
+
+ ;; We must use `file-truename' for the temporary directory, in
+ ;; order to establish the connection prior running an asynchronous
+ ;; process.
+ (let ((default-directory (file-truename tramp-test-temporary-file-directory))
+ (delete-exited-processes t)
+ kill-buffer-query-functions command proc)
+ (skip-unless (consp (list-system-processes)))
+
+ (unwind-protect
+ (progn
+ (setq command '("sleep" "100")
+ proc (apply #'start-file-process "test" nil command))
+ (while (accept-process-output proc 0))
+ (when-let ((pid (process-get proc 'remote-pid))
+ (attributes (process-attributes pid)))
+ ;; (tramp--test-message "%s" attributes)
+ (should (equal (cdr (assq 'comm attributes)) (car command)))
+ (should (equal (cdr (assq 'args attributes))
+ (mapconcat #'identity command " ")))))
+
+ ;; Cleanup.
+ (ignore-errors (delete-process proc)))))
+
(defun tramp--test-async-shell-command
(command output-buffer &optional error-buffer input)
"Like `async-shell-command', reading the output.
INPUT, if non-nil, is a string sent to the process."
(let ((proc (async-shell-command command output-buffer error-buffer))
(delete-exited-processes t))
+ (should (equal (process-get proc 'remote-command)
+ (with-connection-local-variables
+ `(,shell-file-name ,shell-command-switch ,command))))
(cl-letf (((symbol-function #'shell-command-sentinel) #'ignore))
(when (stringp input)
(process-send-string proc input))
diff --git a/test/lisp/progmodes/ruby-mode-resources/ruby.rb b/test/lisp/progmodes/ruby-mode-resources/ruby.rb
index 8c698e4fac8..f31cea86a54 100644
--- a/test/lisp/progmodes/ruby-mode-resources/ruby.rb
+++ b/test/lisp/progmodes/ruby-mode-resources/ruby.rb
@@ -483,3 +483,11 @@ foo bar, {
2 = 3
:foo= if true
{:abc=>4} # not indented, and '=' is not highlighted
+
+# Pattern matching
+case translation
+in ['th', orig_text, 'en', trans_text]
+ puts "English translation: #{orig_text} => #{trans_text}"
+in {'th' => orig_text, 'ja' => trans_text}
+ puts "Japanese translation: #{orig_text} => #{trans_text}"
+end
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 5ba11ed0d57..364e1f8b1de 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -406,6 +406,72 @@ Each element has the format:
(kill-buffer temp-buffer)))))
+;;; General tests for `query-replace' and `query-replace-regexp'.
+
+(defconst query-replace-tests
+ '(
+ ;; query-replace
+ ("aaa" "M-% a RET 1 RET !" "111")
+ ("aaa" "M-% a RET 1 RET y n y" "1a1")
+ ;; Empty inputs
+ ("aaa" "M-% a RET RET !" "")
+ ("aaa" "M-% RET 1 RET !" "1a1a1a")
+ ;; Reuse the previous default
+ ("aaa" "M-% a RET 1 RET . M-% RET !" "111")
+
+ ;; query-replace-regexp
+ ("aaa" "C-M-% a* RET 1 RET !" "1")
+ ;; Empty inputs
+ ("aaa" "C-M-% a* RET RET !" "")
+ ("aaa" "C-M-% RET 1 RET !" "1a1a1a")
+ ;; Empty matches
+ ("aaa" "C-M-% b* RET 1 RET !" "1a1a1a")
+ ;; Complete matches
+ ("aaa" "C-M-% .* RET 1 RET !" "1")
+ ;; Adjacent matches
+ ("abaab" "C-M-% ab* RET 12 RET !" "121212")
+
+ ))
+
+(defun query-replace--perform-tests (tests)
+ (with-temp-buffer
+ (save-window-excursion
+ ;; `execute-kbd-macro' is applied to window only
+ (set-window-buffer nil (current-buffer))
+ (dolist (case tests)
+ ;; Ensure empty input means empty string to replace:
+ (setq query-replace-defaults nil)
+ (delete-region (point-min) (point-max))
+ (insert (nth 0 case))
+ (goto-char (point-min))
+ (execute-kbd-macro (kbd (nth 1 case)))
+ (should (equal (buffer-string) (nth 2 case)))))))
+
+(ert-deftest query-replace-tests ()
+ (query-replace--perform-tests query-replace-tests))
+
+(ert-deftest query-replace-search-function-tests ()
+ (let* ((replace-re-search-function #'re-search-forward))
+ (query-replace--perform-tests query-replace-tests))
+
+ (let* ((pairs '((1 . 2) (3 . 4)))
+ (replace-re-search-function
+ (lambda (string &optional _bound noerror count)
+ (let (found)
+ (while (and (not found) pairs)
+ (goto-char (caar pairs))
+ (when (re-search-forward string (cdar pairs) noerror count)
+ (setq found t))
+ (pop pairs))
+ found)))
+ (tests
+ '(
+ ;; FIXME: this test should pass after fixing bug#54733:
+ ;; ("aaaa" "C-M-% .* RET 1 RET !" "1a1a")
+ )))
+ (query-replace--perform-tests tests)))
+
+
;;; Tests for `query-replace' undo feature.
(defvar replace-tests-bind-read-string nil
diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el
index cd524cbf6e0..ea3f9d05d70 100644
--- a/test/lisp/ses-tests.el
+++ b/test/lisp/ses-tests.el
@@ -22,12 +22,24 @@
;;; Code:
(require 'ert)
+(eval-when-compile (require 'ert-x))
(require 'ses)
;; Silence byte-compiler.
-(with-suppressed-warnings ((lexical A2) (lexical A3))
+(with-suppressed-warnings ((lexical ses--cells)
+ (lexical A2)
+ (lexical A3)
+ (lexical ses--foo)
+ (lexical ses--bar)
+ (lexical B2)
+ (lexical ses--toto))
+ (defvar ses--cells)
(defvar A2)
- (defvar A3))
+ (defvar A3)
+ (defvar ses--foo)
+ (defvar ses--bar)
+ (defvar B2)
+ (defvar ses--toto))
;; PLAIN FORMULA TESTS
;; ======================================================================
@@ -58,9 +70,6 @@ equal to 2. This is done using interactive calls."
;; PLAIN CELL RENAMING TESTS
;; ======================================================================
-(defvar ses--foo)
-(defvar ses--cells)
-
(ert-deftest ses-tests-lowlevel-renamed-cell ()
"Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 to (1+ ses--foo), makes A2 value equal to 2.
This is done using low level functions, `ses-rename-cell' is not
@@ -154,7 +163,6 @@ to A2 and inserting a row, makes A2 value empty, and A3 equal to
(should-not (bound-and-true-p A2))
(should (eq (bound-and-true-p A3) 2)))))
-(defvar ses--bar)
(ert-deftest ses-tests-renamed-cells-row-insertion ()
"Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `ses--foo' and A2 to `ses--bar' jumping
@@ -178,6 +186,61 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to
(should (eq ses--bar 2)))))
+;; JUMP tests
+;; ======================================================================
+(ert-deftest ses-jump-B2-prefix-arg ()
+ "Test jumping to cell B2 by use of prefix argument"
+ (let ((ses-initial-size '(3 . 3))
+ ses-after-entry-functions)
+ (with-temp-buffer
+ (ses-mode)
+ ;; C-u 4 M-x ses-jump
+ (let ((current-prefix-arg 4))
+ (call-interactively 'ses-jump))
+ (should (eq (ses--cell-at-pos (point)) 'B2)))))
+
+
+(ert-deftest ses-jump-B2-lowcase ()
+ "Test jumping to cell B2 by use of lowcase cell name string"
+ (let ((ses-initial-size '(3 . 3))
+ ses-after-entry-functions)
+ (with-temp-buffer
+ (ses-mode)
+ (funcall-interactively 'ses-jump "b2")
+ (ses-command-hook)
+ (should (eq (ses--cell-at-pos (point)) 'B2)))))
+
+(ert-deftest ses-jump-B2-lowcase-keys ()
+ "Test jumping to cell B2 by use of lowcase cell name string with simulating keys"
+ (let ((ses-initial-size '(3 . 3))
+ ses-after-entry-functions)
+ (with-temp-buffer
+ (ses-mode)
+ (ert-simulate-keys [ ?b ?2 return] (ses-jump))
+ (ses-command-hook)
+ (should (eq (ses--cell-at-pos (point)) 'B2)))))
+
+(ert-deftest ses-jump-B2-symbol ()
+ "Test jumping to cell B2 by use of cell name symbol"
+ (let ((ses-initial-size '(3 . 3))
+ ses-after-entry-functions)
+ (with-temp-buffer
+ (ses-mode)
+ (funcall-interactively 'ses-jump 'B2)
+ (ses-command-hook)
+ (should (eq (ses--cell-at-pos (point)) 'B2)))))
+
+(ert-deftest ses-jump-B2-renamed ()
+ "Test jumping to cell B2 after renaming it `ses--toto'."
+ (let ((ses-initial-size '(3 . 3))
+ ses-after-entry-functions)
+ (with-temp-buffer
+ (ses-mode)
+ (ses-rename-cell 'ses--toto (ses-get-cell 1 1))
+ (ses-jump 'ses--toto)
+ (ses-command-hook)
+ (should (eq (ses--cell-at-pos (point)) 'ses--toto)))))
+
(provide 'ses-tests)
;;; ses-tests.el ends here
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 723ef4c710f..c080c483927 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -130,6 +130,49 @@
(should (equal [nil nil nil nil nil t t t t t] (vconcat A)))
(should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A))))))
+(defconst fns-tests--string-lessp-cases
+ '((a 97 error)
+ (97 "a" error)
+ ("abc" "abd" t)
+ ("abd" "abc" nil)
+ (abc "abd" t)
+ ("abd" abc nil)
+ (abc abd t)
+ (abd abc nil)
+ ("" "" nil)
+ ("" " " t)
+ (" " "" nil)
+ ("abc" "abcd" t)
+ ("abcd" "abc" nil)
+ ("abc" "abc" nil)
+ (abc abc nil)
+ ("\0" "" nil)
+ ("" "\0" t)
+ ("~" "\x80" t)
+ ("\x80" "\x80" nil)
+ ("\xfe" "\xff" t)
+ ("Munchen" "München" t)
+ ("München" "Munchen" nil)
+ ("München" "München" nil)
+ ("Ré" "Réunion" t)))
+
+
+(ert-deftest fns-tests-string-lessp ()
+ ;; Exercise both `string-lessp' and its alias `string<', both directly
+ ;; and in a function (exercising its bytecode).
+ (dolist (lessp (list #'string-lessp #'string<
+ (lambda (a b) (string-lessp a b))
+ (lambda (a b) (string< a b))))
+ (ert-info ((prin1-to-string lessp) :prefix "function: ")
+ (dolist (case fns-tests--string-lessp-cases)
+ (ert-info ((prin1-to-string case) :prefix "case: ")
+ (pcase case
+ (`(,x ,y error)
+ (should-error (funcall lessp x y)))
+ (`(,x ,y ,expected)
+ (should (equal (funcall lessp x y) expected)))))))))
+
+
(ert-deftest fns-tests-compare-strings ()
(should-error (compare-strings))
(should-error (compare-strings "xyzzy" "xyzzy"))
@@ -204,6 +247,76 @@
[-1 2 3 4 5 5 7 8 9]))
(should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y)))
[9 8 7 5 5 4 3 2 -1]))
+ ;; Sort a reversed list and vector.
+ (should (equal
+ (sort (reverse (number-sequence 1 1000)) (lambda (x y) (< x y)))
+ (number-sequence 1 1000)))
+ (should (equal
+ (sort (reverse (vconcat (number-sequence 1 1000)))
+ (lambda (x y) (< x y)))
+ (vconcat (number-sequence 1 1000))))
+ ;; Sort a constant list and vector.
+ (should (equal
+ (sort (make-vector 100 1) (lambda (x y) (> x y)))
+ (make-vector 100 1)))
+ (should (equal
+ (sort (append (make-vector 100 1) nil) (lambda (x y) (> x y)))
+ (append (make-vector 100 1) nil)))
+ ;; Sort a long list and vector with every pair reversed.
+ (let ((vec (make-vector 100000 nil))
+ (logxor-vec (make-vector 100000 nil)))
+ (dotimes (i 100000)
+ (aset logxor-vec i (logxor i 1))
+ (aset vec i i))
+ (should (equal
+ (sort logxor-vec (lambda (x y) (< x y)))
+ vec))
+ (should (equal
+ (sort (append logxor-vec nil) (lambda (x y) (< x y)))
+ (append vec nil))))
+ ;; Sort a list and vector with seven swaps.
+ (let ((vec (make-vector 100 nil))
+ (swap-vec (make-vector 100 nil)))
+ (dotimes (i 100)
+ (aset vec i (- i 50))
+ (aset swap-vec i (- i 50)))
+ (mapc (lambda (p)
+ (let ((tmp (elt swap-vec (car p))))
+ (aset swap-vec (car p) (elt swap-vec (cdr p)))
+ (aset swap-vec (cdr p) tmp)))
+ '((48 . 94) (75 . 77) (33 . 41) (92 . 52)
+ (10 . 96) (1 . 14) (43 . 81)))
+ (should (equal
+ (sort (copy-sequence swap-vec) (lambda (x y) (< x y)))
+ vec))
+ (should (equal
+ (sort (append swap-vec nil) (lambda (x y) (< x y)))
+ (append vec nil))))
+ ;; Check for possible corruption after GC.
+ (let* ((size 3000)
+ (complex-vec (make-vector size nil))
+ (vec (make-vector size nil))
+ (counter 0)
+ (my-counter (lambda ()
+ (if (< counter 500)
+ (cl-incf counter)
+ (setq counter 0)
+ (garbage-collect))))
+ (rand 1)
+ (generate-random
+ (lambda () (setq rand
+ (logand (+ (* rand 1103515245) 12345) 2147483647)))))
+ ;; Make a complex vector and its sorted version.
+ (dotimes (i size)
+ (let ((r (funcall generate-random)))
+ (aset complex-vec i (cons r "a"))
+ (aset vec i (cons r "a"))))
+ ;; Sort it.
+ (should (equal
+ (sort complex-vec
+ (lambda (x y) (funcall my-counter) (< (car x) (car y))))
+ (sort vec 'car-less-than-car))))
+ ;; Check for sorting stability.
(should (equal
(sort
(vector
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 862f6a6595f..9ec54c719c8 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -258,5 +258,27 @@ literals (Bug#20852)."
(should (equal (read "-0.e-5") -0.0))
)
+(defun lread-test-read-and-print (str)
+ (let* ((read-circle t)
+ (print-circle t)
+ (val (read-from-string str)))
+ (if (consp val)
+ (prin1-to-string (car val))
+ (error "reading %S failed: %S" str val))))
+
+(defconst lread-test-circle-cases
+ '("#1=(#1# . #1#)"
+ "#1=[#1# a #1#]"
+ "#1=(#2=[#1# #2#] . #1#)"
+ "#1=(#2=[#1# #2#] . #2#)"
+ "#1=[#2=(#1# . #2#)]"
+ "#1=(#2=[#3=(#1# . #2#) #4=(#3# . #4#)])"
+ ))
+
+(ert-deftest lread-circle ()
+ (dolist (str lread-test-circle-cases)
+ (ert-info (str :prefix "input: ")
+ (should (equal (lread-test-read-and-print str) str))))
+ (should-error (read-from-string "#1=#1#") :type 'invalid-read-syntax))
;;; lread-tests.el ends here