diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2024-05-15 09:39:17 +0100 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2024-05-15 09:39:17 +0100 |
| commit | 6c07ad00a3d7b9977a970d33347460a28c0fcbe5 (patch) | |
| tree | a710f2da5fff026f0212a550b622165dc6122a61 | |
| parent | b5b5e58a4caddab516d5a66e6bad1feb367c3e1e (diff) | |
| parent | 184d6e8c02345583264b053bb59ae031bb1c5a00 (diff) | |
| download | emacs-6c07ad00a3d7b9977a970d33347460a28c0fcbe5.tar.gz | |
Merge upstream Git snapshot into athena/unstable
446 files changed, 18793 insertions, 7242 deletions
diff --git a/.gitignore b/.gitignore index 903d4f7f97d..098ad8130bb 100644 --- a/.gitignore +++ b/.gitignore @@ -71,6 +71,10 @@ java/org/gnu/emacs/*.class # Built by `aapt'. java/org/gnu/emacs/R.java +# Built by `make'. +java/org/gnu/emacs/EmacsConfig.java +java/cf-stamp + # Built by `config.status'. java/AndroidManifest.xml @@ -59,6 +59,15 @@ sections if you need to. where SOURCE-DIR is the top-level Emacs source directory. + 2c. If you don't have write access to the default directory where + Emacs and its data files will be installed, specify an alternative + installation directory: + + ./configure --prefix=/SOME/OTHER/DIRECTORY + + where /SOME/OTHER/DIRECTORY is a directory writeable by your user, + for example, a subdirectory of your home directory. + 3. When 'configure' finishes, it prints several lines of details about the system configuration. Read those details carefully looking for anything suspicious, such as wrong CPU and operating @@ -264,6 +273,25 @@ to force GTK+ to run under Broadway, start Emacs like this: The GNUstep build also supports the Wayland window system. If that is what you want, see nextstep/INSTALL. +* Native compilation of Lisp files + +In addition to byte-compiling files of Lisp code, Emacs can also produce +"native code", which usually runs several times faster than the +corresponding byte-compiled code. To build Emacs with this feature, +your system must have not only GCC (the C compiler) and Binutils (the +assembler and linker) but also the 'libgccjit' shared library, which is +part of the GCC distribution. If these components are available, +building Emacs will automatically produce natively compiled Lisp code. + +By default, Emacs natively compiles only pre-loaded Lisp files during +the build process; other Lisp files are natively compiled +"just-in-time", i.e., the first time they are loaded into the running +Emacs. If you want Emacs to natively compile all Lisp files during the +build ("ahead of time"), use the 'configure' option +'--with-native-compilation=aot'. If you do not want natively compiled +Lisp code even if your system satisfies the build requirements, use the +'configure' option '--with-native-compilation=no'. + DETAILED BUILDING AND INSTALLATION: (This is for a Unix or Unix-like system. For GNUstep and macOS, @@ -440,6 +468,12 @@ should put emacs and its data files. This defaults to '/usr/local'. (where CONFIGURATION is the configuration name, like i686-pc-linux-gnu), unless the '--exec-prefix' option says otherwise. +If you don't have write access to the default '/usr/local' tree, and +cannot have root access (without which "make install" will fail), +specify '--prefix=PREFIXDIR' where PREFIXDIR is a directyory writeable +by your user, for example your HOME directory or some subdirectory of +it. + The '--exec-prefix=EXECDIR' option allows you to specify a separate portion of the directory tree for installing architecture-specific files, like executables and utility programs. If specified, @@ -553,10 +587,18 @@ need to create them if you have nothing to put in them. wish to add to various termcap entries. (This is unlikely to be necessary.) 6) Run 'make' in the top directory of the Emacs distribution to finish -building Emacs in the standard way. The final executable file is -named 'src/emacs'. You can execute this file "in place" without -copying it, if you wish; then it automatically uses the sibling -directories ../lisp, ../lib-src, ../info. +building Emacs in the standard way. The final executable file is named +'src/emacs'. You can execute this file "in place" without copying it, +if you wish; then it automatically uses the sibling directories ../lisp, +../lib-src, ../info, ../native-lisp (if built with support for native +compilation). + +If you build Emacs in a directory separate from the source directory +("out-of-tree"), run 'make' in the build directory. Then you can +execute the 'src/emacs' file under that directory "in place". However, +in this case the Emacs executable, while still using the ../lisp and +../info subdirectories of the source tree, will use the ../lib-src and +../native-lisp subdirectories from the build tree. Or you can "install" the executable and the other files into their installed locations, with 'make install'. By default, Emacs's files @@ -574,6 +616,13 @@ are installed in the following directories: at the same time; in particular, you don't have to make Emacs unavailable while installing a new version. +'/usr/local/lib/emacs/VERSION/native-lisp' holds the natively compiled + pre-loaded Emacs Lisp files. If the build used the + 'configure' option '--with-native-compilation=aot', then + this directory holds all natively compiled Lisp files. + +'~/.emacs.d/eln-cache/' holds the just-in-time natively compiled Lisp files. + '/usr/local/share/emacs/VERSION/etc' holds the Emacs tutorial, the DOC file, and other architecture-independent files Emacs might need while running. diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt index 5704e8e8922..9d3de2fa201 100644 --- a/admin/make-tarball.txt +++ b/admin/make-tarball.txt @@ -27,6 +27,13 @@ Steps to take before starting on the first pretest in any release sequence: file against the previously released Emacs version to see what has changed. +5. If this is an emergency release without a prior pretest, inform the + maintainers of the bundled packages which are developed separately + to make sure they install adjustments required for an official + release. Currently, these packages include: + + . Tramp + General steps (for each step, check for possible errors): 1. git pull # fetch from the repository diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index fb0aca87731..0b1cc4d8695 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -32,7 +32,6 @@ EMACS_MAJOR_VERSION="28" PKG_REQ='''mingw-w64-x86_64-giflib mingw-w64-x86_64-gnutls mingw-w64-x86_64-harfbuzz -mingw-w64-x86_64-jansson mingw-w64-x86_64-lcms2 mingw-w64-x86_64-libjpeg-turbo mingw-w64-x86_64-libpng @@ -44,7 +43,6 @@ mingw-w64-x86_64-xpm-nox'''.split() DLL_REQ='''libgif libgnutls libharfbuzz -libjansson liblcms2 libturbojpeg libpng diff --git a/admin/syncdoc-type-hierarchy.el b/admin/syncdoc-type-hierarchy.el index bfbbbc45aa4..ed827844d0b 100644 --- a/admin/syncdoc-type-hierarchy.el +++ b/admin/syncdoc-type-hierarchy.el @@ -35,6 +35,7 @@ ;;; Code: (require 'cl-lib) +(require 'org) (defconst syncdoc-file (or (macroexp-file-name) buffer-file-name)) @@ -96,7 +97,7 @@ (lambda (x1 x2) (< (length (memq (car x2) syncdoc-all-types)) (length (memq (car x1) syncdoc-all-types))))) - (cl-loop for (type . children) in subtypes + (cl-loop for (type . children) in (reverse subtypes) do (insert "|" (symbol-name type) " |") do (cl-loop with x = 0 for child in children diff --git a/build-aux/make-info-dir b/build-aux/make-info-dir index 703abc7bd0a..214757bb65b 100755 --- a/build-aux/make-info-dir +++ b/build-aux/make-info-dir @@ -33,7 +33,8 @@ ## Header contains non-printing characters, so this is more ## reliable than using awk. -cat <"${1?}" || exit +test $# -ge 2 || exit 1 +cat <"$1" shift exec "${AWK-awk}" ' @@ -101,4 +102,4 @@ exec "${AWK-awk}" ' if (data[dircat]) printf "\n%s\n%s", topic[dircat], data[dircat] } -' "${@?}" +' "$@" diff --git a/configure.ac b/configure.ac index bd678ea52a3..69a8ba0a9f8 100644 --- a/configure.ac +++ b/configure.ac @@ -40,7 +40,13 @@ if test "$XCONFIGURE" = "android"; then CFLAGS="$ANDROID_CFLAGS -Werror=implicit-function-declaration" # Don't explicitly enable support for large files unless Emacs is # being built for API 21 or later. Otherwise, mmap does not work. + # + # Moreover, 64-bit variants of file IO functions in the C library are + # liable to fail with ENOSYS or EINVAL on earlier API versions, and as + # such their definitions must be explicitly disabled on NDK releases + # that enable them by default. AS_IF([test "$ANDROID_SDK" -lt "21"], [ + CFLAGS="$CFLAGS -D_FILE_OFFSET_BITS=32" enable_largefile=no enable_year2038=no]) fi @@ -548,7 +554,6 @@ OPTION_DEFAULT_OFF([cairo-xcb], [use XCB surfaces for Cairo support]) OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_OFF([imagemagick],[compile with ImageMagick image support]) OPTION_DEFAULT_ON([native-image-api], [don't use native image APIs (GDI+ on Windows)]) -OPTION_DEFAULT_IFAVAILABLE([json], [compile with native JSON support]) OPTION_DEFAULT_IFAVAILABLE([tree-sitter], [compile with tree-sitter]) OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) @@ -857,6 +862,7 @@ ANDROID_ABI= WARN_JAVAFLAGS= ANDROID_SHARED_USER_ID= ANDROID_SHARED_USER_NAME= +IS_D8_R8= # This is a list of Makefiles that have alternative versions for # Android. @@ -1024,6 +1030,21 @@ Please verify that the path to the SDK build tools you specified is correct]) Please verify that the path to the SDK build tools you specified is correct]) fi + # Locate any d8.jar within the SDK build tools directory. The R8 + # optimizing compiler is also present in this bundle, and it generates + # far superior code. + emacs_val=`which $D8` + emacs_val=`AS_DIRNAME([$emacs_val])`/lib/d8.jar + AS_IF([test -f "$emacs_val"], + [AC_CACHE_CHECK([whether d8.jar coresident with d8 binary provides r8], + [emacs_cv_d8_provides_r8], + [AS_IF([java -cp "$emacs_val" com.android.tools.r8.R8 --help &>/dev/null], + [emacs_cv_d8_provides_r8=yes], [emacs_cv_d8_provides_r8=no])])]) + AS_IF([test "$emacs_cv_d8_provides_r8" = "yes"], + # And substitute it for D8 if present. + [D8="java -cp $emacs_val com.android.tools.r8.R8" + IS_D8_R8=yes]) + AC_PATH_PROGS([ZIPALIGN], [zipalign], [], "${SDK_BUILD_TOOLS}:$PATH") if test "ZIPALIGN" = ""; then AC_MSG_ERROR([The Android ZIP archive alignment utility was not found. @@ -1216,7 +1237,6 @@ package will likely install on older systems but crash on startup.]) passthrough="$passthrough --with-png=$with_png" passthrough="$passthrough --with-webp=$with_webp" passthrough="$passthrough --with-gif=$with_gif" - passthrough="$passthrough --with-json=$with_json" passthrough="$passthrough --with-jpeg=$with_jpeg" passthrough="$passthrough --with-xml2=$with_xml2" passthrough="$passthrough --with-sqlite3=$with_sqlite3" @@ -1283,6 +1303,7 @@ AC_SUBST([D8]) AC_SUBST([ZIPALIGN]) AC_SUBST([ANDROID_JAR]) AC_SUBST([ANDROID_ABI]) +AC_SUBST([IS_D8_R8]) if test "$XCONFIGURE" = "android"; then ANDROID=yes @@ -1305,7 +1326,6 @@ if test "$ANDROID" = "yes"; then with_png=no with_webp=no with_gif=no - with_json=no with_jpeg=no with_xml2=no with_sqlite3=no @@ -4005,27 +4025,6 @@ fi AC_SUBST([LIBSYSTEMD_LIBS]) AC_SUBST([LIBSYSTEMD_CFLAGS]) -HAVE_JSON=no -JSON_OBJ= - -if test "${with_json}" != no; then - EMACS_CHECK_MODULES([JSON], [jansson >= 2.7], - [HAVE_JSON=yes], [HAVE_JSON=no]) - if test "${HAVE_JSON}" = yes; then - AC_DEFINE([HAVE_JSON], [1], [Define if using Jansson.]) - JSON_OBJ=json.o - fi - - # Windows loads libjansson dynamically - if test "${opsys}" = "mingw32"; then - JSON_LIBS= - fi -fi - -AC_SUBST([JSON_LIBS]) -AC_SUBST([JSON_CFLAGS]) -AC_SUBST([JSON_OBJ]) - HAVE_TREE_SITTER=no TREE_SITTER_OBJ= NEED_DYNLIB=no @@ -5470,11 +5469,6 @@ case $with_gnutls,$HAVE_GNUTLS in *) MISSING="$MISSING gnutls" WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-gnutls=ifavailable";; esac -case $with_json,$HAVE_JSON in - no,* | ifavailable,* | *,yes) ;; - *) MISSING="$MISSING json" - WITH_IFAVAILABLE="$WITH_IFAVAILABLE --with-json=ifavailable";; -esac case $with_tree_sitter,$HAVE_TREE_SITTER in no,* | ifavailable,* | *,yes) ;; *) MISSING="$MISSING tree-sitter" @@ -7655,7 +7649,7 @@ Configured for '${canonical}'. optsep= emacs_config_features= for opt in ACL BE_APP CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \ - HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \ + HARFBUZZ IMAGEMAGICK JPEG LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \ M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PGTK PNG RSVG SECCOMP \ SOUND SQLITE3 THREADS TIFF TOOLKIT_SCROLL_BARS TREE_SITTER \ UNEXEC WEBP X11 XAW3D XDBE XFT XIM XINPUT2 XPM XWIDGETS X_TOOLKIT \ @@ -7731,7 +7725,6 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use -lotf? ${HAVE_LIBOTF} Does Emacs use -lxft? ${HAVE_XFT} Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} - Does Emacs use -ljansson? ${HAVE_JSON} Does Emacs use -ltree-sitter? ${HAVE_TREE_SITTER} Does Emacs use the GMP library? ${HAVE_GMP} Does Emacs directly use zlib? ${HAVE_ZLIB} diff --git a/cross/Makefile.in b/cross/Makefile.in index 6f2250fe02f..575c6c4cb29 100644 --- a/cross/Makefile.in +++ b/cross/Makefile.in @@ -140,16 +140,22 @@ src/Makefile: $(top_builddir)/src/Makefile.android -e 's/\.\.\/admin\/charsets/..\/..\/admin\/charsets/g' \ -e 's/^libsrc =.*$$/libsrc = \.\.\/\.\.\/lib-src/g' \ -e 's/libsrc =.*$$/libsrc = \.\.\/\.\.\/lib-src/g' \ - -e 's/-I\$$(top_srcdir)\/lib/-I..\/$(subst /,\/,$(srcdir))\/lib/g' \ + -e 's/-I\$$(top_srcdir)\/lib//g' \ < $(top_builddir)/src/Makefile.android > $@ +src/epaths.h: $(top_builddir)/src/epaths.h + $(AM_V_GEN) cp -f -p $< $@ + +src/emacs-module.h: $(top_builddir)/src/emacs-module.h + $(AM_V_GEN) cp -f -p $< $@ + src/config.h: $(top_builddir)/src/config.h.android $(AM_V_GEN) cp -f -p $< $@ .PHONY: src/android-emacs src/libemacs.so -src/libemacs.so: src/Makefile src/config.h src/verbose.mk \ - lib/libgnu.a $(PRE_BUILD_DEPS) +src/libemacs.so: src/Makefile src/config.h src/epaths.h \ + src/verbose.mk src/emacs-module.h lib/libgnu.a $(PRE_BUILD_DEPS) $(MAKE) -C src libemacs.so src/android-emacs: src/Makefile src/config.h lib/libgnu.a \ diff --git a/cross/ndk-build/ndk-build.mk.in b/cross/ndk-build/ndk-build.mk.in index ea1be5af6f1..9948e019e3b 100644 --- a/cross/ndk-build/ndk-build.mk.in +++ b/cross/ndk-build/ndk-build.mk.in @@ -27,6 +27,7 @@ NDK_BUILD_CXX_LDFLAGS = @NDK_BUILD_CXX_LDFLAGS@ NDK_BUILD_ANY_CXX_MODULE = @NDK_BUILD_ANY_CXX_MODULE@ NDK_BUILD_SHARED = NDK_BUILD_STATIC = +NDK_BUILD_READELF = @NDK_BUILD_READELF@ define uniqify $(if $1,$(firstword $1) $(call uniqify,$(filter-out $(firstword $1),$1))) diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index 01732961998..09b7762ed03 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -148,7 +148,7 @@ attempts to open the file with the wrapper will fail. system provides access to outside the normal filesystem APIs. Emacs uses pseudo-directories named @file{/content/by-authority} and @file{/content/by-authority-named} to access those files. Do not make -any assumptions about the contents of this directory, or try to open +any assumptions about the contents of these directories, or try to open files in it yourself. This feature is not provided on Android 4.3 and earlier, in which @@ -299,8 +299,8 @@ on some proprietary versions of Android. @cindex /content/storage directory, Android Android 5.0 introduces a new sort of program, the ``document -provider'': these programs are small programs that provide access to -their own files outside both the asset manager and the Unix +provider'': these programs are small services that provide access to +their own files independently of the asset manager and the Unix filesystem. Emacs supports accessing files and directories they provide, placing their files within the directory @file{/content/storage}. @@ -311,12 +311,15 @@ first request the right to access it. This is done by running the command (@pxref{M-x}) @code{android-request-directory-access}, which displays a file selection dialog. - If a directory is selected within this dialog, its contents are + If a directory is selected from this dialog, its contents are subsequently made available within a new directory named -@file{/content/storage/@var{authority}/@var{id}}, where -@var{authority} is the name of the document provider, and @var{id} is -a unique identifier assigned to the directory by the document -provider. +@file{/content/storage/@var{authority}/@var{id}}, where @var{authority} +is the name of the document provider, and @var{id} is a unique +identifier assigned to the directory by the document provider. + +@findex android-relinquish-directory-access + Such a directory can be deleted once no longer required by providing +its name to the command @code{android-relinquish-directory-access}. The same limitations applied to the @file{/assets} directory (@pxref{Android File System}) are applied when creating sub-processes @@ -820,67 +823,73 @@ example, the permission to access contacts may be useful for EUDC. @node Android Windowing @section The Android Window System - Android's window system is unusual, in that all windows are -maximized or full-screen, and only one window can be displayed at a -time. On larger devices, the system permits simultaneously tiling up -to four windows on the screen. - - Windows on Android do not exist indefinitely after they are created. -Instead, the system may choose to close windows that are not on screen -in order to conserve memory, with the assumption that the program will -save its contents to disk and restore them later, when the user asks -for it to be opened again. As this is obviously not possible with -Emacs, Emacs separates the resources associated with a frame from its -system window. - - Each system window created (including the initial window created -during Emacs startup) is appended to a list of windows that do not -have associated frames. When a frame is created, Emacs looks up any -window within that list, and displays the contents of the frame -within; if there is no window at all, then one is created. Likewise, -when a new window is created by the system, Emacs places the contents -of any frame that is not already displayed within a window inside. -When a frame is closed, the corresponding system window is also -closed. Upon startup, the system creates a window itself (within -which Emacs displays the first window system frame shortly -thereafter.) Emacs differentiates between that window and windows -created on behalf of other frames to determine what to do when the -system window associated with a frame is closed: + Android's window system is unusual in that all windows are reported to +applications as maximized or full-screen, and, in the general case, only +one window can be displayed at a time. On larger devices, the system +permits simultaneously tiling up to four windows on the screen, though +in emulators or installations configured for ``desktop'' systems stacks +freely resizable windows as other desktop window managers do. + + Windows, or, in system nomenclature, activities, do not exist +indefinitely after creation, as the system may choose to pause windows +that are not visible in order to conserve memory, on the assumption that +the program will save its contents to disk, to be restored when the user +selects those windows from the task switcher. Furthermore, a window is +created by the operating system at Emacs startup that is afforded +special treatment, which Emacs is expected to adopt. + + Emacs approaches window management with the general objective of +minimizing differences in frame behavior exposed to Lisp from that of +frames on ordinary window systems, such as X Windows; the degree to +which this goal is actually attained varies by the availability of +facilities for window management in the version of Android where it is +installed, and operating system policy towards inactive windows. When +it is unavoidable that concessions should be made to such policy, Emacs +prefers destroying frames to retaining ones with no activities to +display them, unless such a frame is the initial frame and therefore +displayed in the activity created at startup, which it is possible to +open and identify so long as Emacs is yet executing. + +@cindex frames and windows, Android 5.0 + Android 5.0 and later support an accurate implementation of window +management where frames hold a one-to-one relation to the activities in +which they are displayed, enabling deletion of activities in the task +switcher to directly affect the frames concerned, and vice versa. There +are just two exceptions: @itemize @bullet @item -When the system closes the window created during application startup -in order to save memory, Emacs retains the frame for when that window -is created later. - -@item -When the user closes the window created during application startup, -and the window was not previously closed by the system in order to -save resources, Emacs deletes any frame displayed within that window. - -However, on Android 7.0 and later, such frames are not deleted if the -window is closed four or more hours after the window moves into the -background, as the system automatically removes open windows once a -certain period of inactivity elapses when the number of windows retained -by the window manager surpasses a specific threshold, and window -deletion by this mechanism is indistinguishable from window deletion by -the user. Emacs begins to ignore window deletion after two hours less -than the default value of this threshold both to err on the side of -caution, in case the system's record of inactivity and Emacs's differ, -and for the reason that this threshold is open to customization by OS -distributors. - -@item -When the user or the system closes any window created by Emacs on -behalf of a specific frame, Emacs deletes the frame displayed within -that window. +After the system pauses an activity that remains in the task switcher in +response to inactivity, removing it from the task switcher while it +remains in its inactive state will not delete the frame inside, as Emacs +is not notified of the deletion of its activities in such circumstances. +The frame will be deleted upon the next window management operation that +prompts an examination of the list of live windows. Likewise, an +inactive activity displaying a frame will not be immediately deleted +with its frame, but will be if it is selected from the window list or +upon another examination of the window list. + +@item +Any frame besides the initial frame might be deleted after 4 to 6 hours +of inactivity in the background, if it is removed by the system in +``trimming'' the task switcher of excess, and presumably unwanted, +tasks; the initial frame is exempt from this treatment because it can be +reopened otherwise than from the task switcher, but as deletion by this +mechanism is indistinguishable from legitimate user action to remove +activities from the task switcher, the latter will also be ignored by +the initial frame after a 4-hour interval elapses from the time of last +activity. @end itemize - When the system predates Android 5.0, the window manager will not -accept more than one user-created Emacs window. If frame creation gives -rise to windows in excess of this limit, the window manager will -arbitrarily select one of their number to display, with the rest -remaining invisible until that window is destroyed with its frame. +@cindex frames and windows, Android 4.4 +@cindex frames and windows, Android 2.2 + Android 4.4 and earlier provide considerably inferior interfaces +inadequate for a complete implementation of window management. On such +systems, Emacs substitutes a fairly primitive mechanism where all but +the initial frame are deleted when their activities are paused, only a +single activity (not counting the activity created at startup) is +visible at a time, and unattached frames are displayed in the first +unoccupied activity available. @cindex windowing limitations, android @cindex frame parameters, android @@ -895,9 +904,9 @@ devices. @item The @code{alpha}, @code{alpha-background}, @code{z-group}, @code{override-redirect}, @code{mouse-color}, @code{title}, -@code{wait-for-wm}, @code{sticky}, @code{undecorated} and -@code{tool-bar-position} frame parameters (@pxref{Frame Parameters,,, -elisp, the Emacs Lisp Reference Manual}) are unsupported. +@code{wait-for-wm}, @code{sticky}, and @code{undecorated} frame +parameters (@pxref{Frame Parameters,,, elisp, the Emacs Lisp Reference +Manual}) are unsupported. @item On Android 4.0 and earlier, the @code{fullscreen} frame parameter is @@ -939,13 +948,16 @@ application via cut-and-paste. @vindex android-pass-multimedia-buttons-to-system @cindex volume/multimedia buttons, Android - The volume keys are normally reserved by Emacs and used to provide -the ability to quit Emacs without a physical keyboard -(@pxref{On-Screen Keyboards}.) However, if you want them to adjust -the volume instead, you can set the variable + The volume keys are normally reserved by Emacs and used to provide the +ability to quit Emacs without a physical keyboard (@pxref{On-Screen +Keyboards}). However, if you want them to adjust the volume instead, +you can set the variable @code{android-pass-multimedia-buttons-to-system} to a non-@code{nil} value; note that you will no longer be able to quit Emacs using the -volume buttons in that case. +volume buttons in that case, and that it is generally easier to activate +the notification shade or another interface that momentarily deprives +Emacs of the keyboard focus while the volume buttons are being +depressed. @cindex dialog boxes, android Emacs is unable to display dialog boxes (@pxref{Dialog Boxes}) while @@ -993,12 +1005,31 @@ customized through altering the variable @code{android-keyboard-bell-duration} to any value between @code{10} and @code{1000}. +@vindex android-display-planes +@cindex visual class, Android +@cindex display color space, Android + Color-related characteristics of the display are not automatically +detectable on Android, so the variable @code{android-display-planes} +should be configured to a suitable value if Emacs is to realize faces +and images in a manner consistent with the true visual attributes of a +grayscale or monochrome display: to @code{8} for the former class of +display, and @code{1} for the latter, which will, respectively, force +all colors to be rendered in 256 grays, or in monochrome. As this +variable is processed at the time the display connection is established, +customizations will not take effect unless they be performed from +@code{early-init.el} (@pxref{Early Init File}). + + The value of this variable does not affect anti-aliasing in the font +driver, as monochrome displays nevertheless expect Emacs to provide +antialiased text, which they receive after it is processed into bitmap +data by the display driver. + @node Android Fonts @section Font Backends and Selection under Android @cindex fonts, android - Emacs supports two font backends under Android: they are -respectively named @code{sfnt-android} and @code{android}. + Emacs supports two font backends under Android: they are respectively +named @code{sfnt-android} and @code{android}. Upon startup, Emacs enumerates all the TrueType format fonts in the directories @file{/system/fonts} and @file{/product/fonts}, and the diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 7312cfb34c9..10fe404099d 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -104,8 +104,11 @@ Move point one year backward (@code{calendar-backward-year}). The day and week commands are natural analogues of the usual Emacs commands for moving by characters and by lines. Just as @kbd{C-n} usually moves to the same column in the following line, in Calendar -mode it moves to the same day in the following week. And @kbd{C-p} -moves to the same day in the previous week. +mode it is bound to @code{calendar-forward-week}, which moves to the +same day in the following week. And @kbd{C-p} +(@code{calendar-backward-week} moves to the same day in the previous +week. @kbd{C-f} (@code{calendar-forward-day}) and @kbd{C-b} +(@code{calendar-backward-day}) move forward and back by days. The arrow keys are equivalent to @kbd{C-f}, @kbd{C-b}, @kbd{C-n} and @kbd{C-p}, just as they normally are in other modes. @@ -119,10 +122,12 @@ moves to the same day in the previous week. @kindex C-x [ @r{(Calendar mode)} @findex calendar-backward-year The commands for motion by months and years work like those for -weeks, but move a larger distance. The month commands @kbd{M-@}} and -@kbd{M-@{} move forward or backward by an entire month. The year -commands @kbd{C-x ]} and @w{@kbd{C-x [}} move forward or backward a -whole year. +weeks, but move a larger distance. The month commands @kbd{M-@}} +(@code{calendar-forward-month}) and @kbd{M-@{} +(@code{calendar-backward-month}) move forward or backward by an entire +month. The year commands @w{@kbd{C-x ]}} +(@code{calendar-forward-year}) and @w{@kbd{C-x [}} +(@code{calendar-backward-year}) move forward or backward a whole year. The easiest way to remember these commands is to consider months and years analogous to paragraphs and pages of text, respectively. But @@ -261,8 +266,9 @@ Scroll backward by three months (@code{calendar-scroll-right-three-months}). @findex calendar-scroll-right The most basic calendar scroll commands scroll by one month at a time. This means that there are two months of overlap between the -display before the command and the display after. @kbd{>} scrolls the -calendar contents one month forward in time. @kbd{<} scrolls the +display before the command and the display after. @kbd{>} +(@code{calendar-scroll-left}) scrolls the calendar contents one month +forward in time. @kbd{<} (@code{calendar-scroll-right}) scrolls the contents one month backwards in time. @kindex C-v @r{(Calendar mode)} @@ -273,13 +279,15 @@ contents one month backwards in time. @kindex PageUp @r{(Calendar mode)} @kindex prior @r{(Calendar mode)} @findex calendar-scroll-right-three-months - The commands @kbd{C-v} and @kbd{M-v} scroll the calendar by an entire -screenful---three months---in analogy with the usual meaning of -these commands. @kbd{C-v} makes later dates visible and @kbd{M-v} makes -earlier dates visible. These commands take a numeric argument as a -repeat count; in particular, since @kbd{C-u} multiplies the next command -by four, typing @kbd{C-u C-v} scrolls the calendar forward by a year and -typing @kbd{C-u M-v} scrolls the calendar backward by a year. + The commands @kbd{C-v} (@code{calendar-scroll-left-three-months}) +and @kbd{M-v} (@code{calendar-scroll-right-three-months}) scroll the +calendar by an entire screenful---three months---in analogy with the +usual meaning of these commands. @kbd{C-v} makes later dates visible +and @kbd{M-v} makes earlier dates visible. These commands take a +numeric argument as a repeat count; in particular, since @kbd{C-u} +multiplies the next command by four, typing @kbd{C-u C-v} scrolls the +calendar forward by a year and typing @kbd{C-u M-v} scrolls the +calendar backward by a year. The function keys @key{PageDown} (or @key{next}) and @key{PageUp} (or @key{prior}) are equivalent to @kbd{C-v} and @kbd{M-v}, just as @@ -358,6 +366,8 @@ calendar deletes or iconifies that frame depending on the value of You can write calendars and diary entries to HTML and @LaTeX{} files. @cindex calendar and HTML +@vindex cal-html-directory +@vindex cal-html-holidays The Calendar HTML commands produce files of HTML code that contain calendar, holiday, and diary entries. Each file applies to one month, and has a name of the format @file{@var{yyyy}-@var{mm}.html}, where @@ -382,10 +392,13 @@ Generate a one-month calendar (@code{cal-html-cursor-month}). @item H y Generate a calendar file for each month of a year, as well as an index page (@code{cal-html-cursor-year}). By default, this command writes -files to a @var{yyyy} subdirectory---if this is altered some hyperlinks -between years will not work. +files to a @var{year} subdirectory, where @var{year} is the year at +cursor---if this is altered, some hyperlinks between years will not +work. @end table +@vindex cal-html-print-day-number-flag +@vindex cal-html-year-index-cols If the variable @code{cal-html-print-day-number-flag} is non-@code{nil}, then the monthly calendars show the day-of-the-year number. The variable @code{cal-html-year-index-cols} specifies the @@ -444,6 +457,9 @@ paper size (3.75in x 6.75in). All of these commands accept a prefix argument, which specifies how many days, weeks, months or years to print (starting always with the selected one). +@vindex cal-tex-holidays +@vindex cal-tex-diary +@vindex cal-tex-rules If the variable @code{cal-tex-holidays} is non-@code{nil} (the default), then the printed calendars show the holidays in @code{calendar-holidays}. If the variable @code{cal-tex-diary} is non-@code{nil} (the default is @@ -454,6 +470,7 @@ pages in styles that have sufficient room. Consult the documentation of the individual cal-tex functions to see which calendars support which features. +@vindex cal-tex-preamble-extra You can use the variable @code{cal-tex-preamble-extra} to insert extra @LaTeX{} commands in the preamble of the generated document if you need to. @@ -486,12 +503,12 @@ List holidays in another window for a specified range of years. @kindex h @r{(Calendar mode)} @findex calendar-cursor-holidays -@vindex calendar-view-holidays-initially-flag To see if any holidays fall on a given date, position point on that -date in the calendar window and use the @kbd{h} command. Alternatively, -click on that date with @kbd{mouse-3} and then choose @kbd{Holidays} -from the menu that appears. Either way, this displays the holidays for -that date, in the echo area if they fit there, otherwise in a separate +date in the calendar window and use the @kbd{h} +(@code{calendar-cursor-holidays}) command. Alternatively, click on +that date with @kbd{mouse-3} and then choose @kbd{Holidays} from the +menu that appears. Either way, this displays the holidays for that +date, in the echo area if they fit there, otherwise in a separate window. @kindex x @r{(Calendar mode)} @@ -500,8 +517,8 @@ window. @findex calendar-unmark @vindex calendar-mark-holidays-flag To view the distribution of holidays for all the dates shown in the -calendar, use the @kbd{x} command. This displays the dates that are -holidays in a different face. +calendar, use the @kbd{x} (@code{calendar-mark-holidays}) command. +This displays the dates that are holidays in a different face. @iftex @xref{Calendar Customizing,,, emacs-xtra, Specialized Emacs Features}. @end iftex @@ -510,19 +527,22 @@ holidays in a different face. @end ifnottex The command applies both to the currently visible months and to other months that subsequently become visible by scrolling. To turn -marking off and erase the current marks, type @kbd{u}, which also -erases any diary marks (@pxref{Diary}). If the variable -@code{calendar-mark-holidays-flag} is non-@code{nil}, creating or -updating the calendar marks holidays automatically. +marking off and erase the current marks, type @kbd{u} +(@code{calendar-unmark}), which also erases any diary marks +(@pxref{Diary}). If the variable @code{calendar-mark-holidays-flag} +is non-@code{nil}, creating or updating the calendar marks holidays +automatically. @kindex a @r{(Calendar mode)} @findex calendar-list-holidays - To get even more detailed information, use the @kbd{a} command, which -displays a separate buffer containing a list of all holidays in the -current three-month range. You can use @key{SPC} and @key{DEL} in the -calendar window to scroll that list up and down, respectively. + To get even more detailed information, use the @kbd{a} +(@code{calendar-list-holidays}) command, which displays a separate +buffer containing a list of all holidays in the current three-month +range. You can use @key{SPC} and @key{DEL} in the calendar window to +scroll that list up and down, respectively. @findex holidays +@vindex calendar-view-holidays-initially-flag The command @kbd{M-x holidays} displays the list of holidays for the current month and the preceding and succeeding months; this works even if you don't have a calendar window. If the variable @@ -536,6 +556,7 @@ major Bahá'í, Chinese, Christian, Islamic, and Jewish holidays; also the solstices and equinoxes. @findex list-holidays +@findex holiday-list The command @kbd{M-x holiday-list} displays the list of holidays for a range of years. This function asks you for the starting and stopping years, and allows you to choose all the holidays or one of several @@ -569,14 +590,14 @@ Display times of sunrise and sunset for the selected month. @kindex S @r{(Calendar mode)} @findex calendar-sunrise-sunset @findex sunrise-sunset - Within the calendar, to display the @emph{local times} of sunrise and -sunset in the echo area, move point to the date you want, and type -@kbd{S}. Alternatively, click @kbd{mouse-3} on the date, then choose -@samp{Sunrise/sunset} from the menu that appears. The command @kbd{M-x -sunrise-sunset} is available outside the calendar to display this -information for today's date or a specified date. To specify a date -other than today, use @kbd{C-u M-x sunrise-sunset}, which prompts for -the year, month, and day. + Within the calendar, to display the @emph{local times} of sunrise +and sunset in the echo area, move point to the date you want, and type +@kbd{S} (@code{calendar-sunrise-sunset}). Alternatively, click +@kbd{mouse-3} on the date, then choose @samp{Sunrise/sunset} from the +menu that appears. The command @kbd{M-x sunrise-sunset} is available +outside the calendar to display this information for today's date or a +specified date. To specify a date other than today, use @kbd{C-u M-x +sunrise-sunset}, which prompts for the year, month, and day. You can display the times of sunrise and sunset for any location and any date with @kbd{C-u C-u M-x sunrise-sunset}. This asks you for a @@ -584,13 +605,13 @@ longitude, latitude, number of minutes difference from Coordinated Universal Time, and date, and then tells you the times of sunrise and sunset for that location on that date. +@vindex calendar-location-name +@vindex calendar-longitude +@vindex calendar-latitude Because the times of sunrise and sunset depend on the location on earth, you need to tell Emacs your latitude, longitude, and location name before using these commands. Here is an example of what to set: -@vindex calendar-location-name -@vindex calendar-longitude -@vindex calendar-latitude @example (setq calendar-latitude 40.1) (setq calendar-longitude -88.2) @@ -601,14 +622,14 @@ name before using these commands. Here is an example of what to set: Use one decimal place in the values of @code{calendar-latitude} and @code{calendar-longitude}. +@vindex calendar-time-zone +@vindex calendar-standard-time-zone-name +@vindex calendar-daylight-time-zone-name Your time zone also affects the local time of sunrise and sunset. Emacs usually gets time zone information from the operating system, but if these values are not what you want (or if the operating system does not supply them), you must set them yourself. Here is an example: -@vindex calendar-time-zone -@vindex calendar-standard-time-zone-name -@vindex calendar-daylight-time-zone-name @example (setq calendar-time-zone -360) (setq calendar-standard-time-zone-name "CST") @@ -616,9 +637,9 @@ not supply them), you must set them yourself. Here is an example: @end example @noindent -The value of @code{calendar-time-zone} is the number of minutes +The value of @code{calendar-time-zone} is the number of minutes of difference between your local standard time and Coordinated Universal -Time (Greenwich time). The values of +Time (a.k.a.@: ``Greenwich time''). The values of @code{calendar-standard-time-zone-name} and @code{calendar-daylight-time-zone-name} are the abbreviations used in your time zone. Emacs displays the times of sunrise and sunset @@ -627,7 +648,8 @@ for how daylight saving time is determined. @vindex calendar-time-zone-style If you want to display numerical time zones (like @samp{"+0100"}) -instead of symbolic ones (like @samp{"CET"}), set this to @code{numeric}. +instead of symbolic ones (like @samp{"CET"}), set the variable +@code{calendar-time-zone-style} to @code{numeric}. As a user, you might find it convenient to set the calendar location variables for your usual physical location in your @file{.emacs} file. @@ -639,10 +661,10 @@ for all users in a @file{default.el} file. @xref{Init File}. @cindex phases of the moon @cindex moon, phases of - These calendar commands display the dates and times of the phases of -the moon (new moon, first quarter, full moon, last quarter). This -feature is useful for debugging problems that depend on the phase of -the moon. + The calendar commands described in this section display the dates +and times of the phases of the moon (new moon, first quarter, full +moon, last quarter). This feature is useful for debugging problems +that depend on the phase of the moon. @table @kbd @item M @@ -655,9 +677,10 @@ today's date. @kindex M @r{(Calendar mode)} @findex calendar-lunar-phases - Within the calendar, use the @kbd{M} command to display a separate -buffer of the phases of the moon for the current three-month range. The -dates and times listed are accurate to within a few minutes. + Within the calendar, use the @kbd{M} (@code{calendar-lunar-phases}) +command to display a separate buffer of the phases of the moon for the +current three-month range. The dates and times listed are accurate to +within a few minutes. @findex lunar-phases Outside the calendar, use the command @kbd{M-x lunar-phases} to @@ -668,21 +691,22 @@ year. The dates and times given for the phases of the moon are given in local time (corrected for daylight saving, when appropriate). -See the discussion in the previous section. @xref{Sunrise/Sunset}. +See the discussion in the previous section (@pxref{Sunrise/Sunset}). @node Other Calendars @section Conversion To and From Other Calendars @cindex Gregorian calendar - The Emacs calendar displayed is @emph{always} the Gregorian calendar, -sometimes called the New Style calendar, which is used in most of -the world today. However, this calendar did not exist before the -sixteenth century and was not widely used before the eighteenth century; -it did not fully displace the Julian calendar and gain universal -acceptance until the early twentieth century. The Emacs calendar can -display any month since January, year 1 of the current era, but the -calendar displayed is always the Gregorian, even for a date at which -the Gregorian calendar did not exist. +@cindex New Style calendar + The Emacs calendar displayed is @emph{always} the @dfn{Gregorian +calendar}, sometimes called the @dfn{New Style calendar}, which is +used in most of the world today. However, this calendar did not exist +before the sixteenth century and was not widely used before the +eighteenth century; it did not fully displace the Julian calendar and +gain universal acceptance until the early twentieth century. The +Emacs calendar can display any month since January, year 1 of the +current era, but the calendar displayed is always the Gregorian, even +for a date at which the Gregorian calendar did not exist. While Emacs cannot display other calendars, it can convert dates to and from several other calendars. @@ -711,7 +735,8 @@ century. @cindex astronomical day numbers Astronomers use a simple counting of days elapsed since noon, Monday, January 1, 4713 BC on the Julian calendar. The number of days elapsed -is called the @dfn{Julian day number} or the @dfn{Astronomical day number}. +since then is called the @dfn{Julian day number} or the +@dfn{Astronomical day number}. @cindex Hebrew calendar The Hebrew calendar is used by tradition in the Jewish religion. The @@ -736,6 +761,10 @@ the metric system. The French government officially abandoned this calendar at the end of 1805. @cindex Mayan calendars +@cindex long count calendar system +@cindex tzolkin calendar system +@cindex haab calendar system +@cindex Goodman-Martinez-Thompson correlation The Maya of Central America used three separate, overlapping calendar systems, the @emph{long count}, the @emph{tzolkin}, and the @emph{haab}. Emacs knows about all three of these calendars. Experts dispute the @@ -751,6 +780,7 @@ extra period to make it six days. The Ethiopic calendar is identical in structure, but has different year numbers and month names. @cindex Persian calendar +@cindex Birashk The Persians use a solar calendar based on a design of Omar Khayyam. Their calendar consists of twelve months of which the first six have 31 days, the next five have 30 days, and the last has 29 in ordinary years @@ -840,13 +870,13 @@ Display Mayan date for selected day (@code{calendar-mayan-print-date}). Otherwise, move point to the date you want to convert, then type the appropriate command starting with @kbd{p} from the table above. The prefix @kbd{p} is a mnemonic for ``print'', since Emacs ``prints'' the -equivalent date in the echo area. @kbd{p o} displays the -date in all forms known to Emacs. You can also use @kbd{mouse-3} and -then choose @kbd{Other calendars} from the menu that appears. This -displays the equivalent forms of the date in all the calendars Emacs -understands, in the form of a menu. (Choosing an alternative from -this menu doesn't actually do anything---the menu is used only for -display.) +equivalent date in the echo area. @kbd{p o} +(@code{calendar-print-other-dates}) displays the date in all forms +known to Emacs. You can also use @kbd{mouse-3} and then choose +@kbd{Other calendars} from the menu that appears. This displays the +equivalent forms of the date in all the calendars Emacs understands, +in the form of a menu. (Choosing an alternative from this menu +doesn't actually do anything---the menu is used only for display.) @node From Other Calendar @subsection Converting From Other Calendars @@ -1053,10 +1083,11 @@ Mail yourself email reminders about upcoming diary entries. @kindex d @r{(Calendar mode)} @findex diary-view-entries @vindex calendar-view-diary-initially-flag - Displaying the diary entries with @kbd{d} shows in a separate buffer -the diary entries for the selected date in the calendar. The mode line -of the new buffer shows the date of the diary entries. Holidays are -shown either in the buffer or in the mode line, depending on the display + Displaying the diary entries with @kbd{d} +(@code{diary-view-entries}) shows in a separate buffer the diary +entries for the selected date in the calendar. The mode line of the +new buffer shows the date of the diary entries. Holidays are shown +either in the buffer or in the mode line, depending on the display method you choose @iftex (@pxref{Diary Display,,, emacs-xtra, Specialized Emacs Features}). @@ -1079,8 +1110,8 @@ current date is visible). @findex diary-mark-entries @vindex calendar-mark-diary-entries-flag To get a broader view of which days are mentioned in the diary, use -the @kbd{m} command. This marks the dates that have diary entries in -a different face. +the @kbd{m} (@code{diary-mark-entries}) command. This marks the dates +that have diary entries in a different face. @iftex @xref{Calendar Customizing,,, emacs-xtra, Specialized Emacs Features}. @end iftex @@ -1089,9 +1120,10 @@ a different face. @end ifnottex This command applies both to the months that are currently visible -and to those that subsequently become visible after scrolling. To turn -marking off and erase the current marks, type @kbd{u}, which also -turns off holiday marks (@pxref{Holidays}). If the variable +and to those that subsequently become visible after scrolling. To +turn marking off and erase the current marks, type @kbd{u} +(@code{calendar-unmark}), which also turns off holiday marks +(@pxref{Holidays}). If the variable @code{calendar-mark-diary-entries-flag} is non-@code{nil}, creating or updating the calendar marks diary dates automatically. @@ -1107,9 +1139,10 @@ otherwise mark many different dates. @kindex s @r{(Calendar mode)} @findex diary-show-all-entries To see the full diary file, rather than just some of the entries, use -the @kbd{s} command. +the @kbd{s} (@code{diary-show-all-entries}) command. @findex diary +@vindex diary-number-of-entries The command @kbd{M-x diary} displays the diary entries for the current date, independently of the calendar display, and optionally for the next few days as well; the variable @code{diary-number-of-entries} specifies @@ -1161,6 +1194,9 @@ and @var{day} are numbers of one or two digits. The optional @var{year} is also a number, and may be abbreviated to the last two digits; that is, you can use @samp{11/12/2012} or @samp{11/12/12}. +@vindex calendar-abbrev-length +@vindex calendar-month-abbrev-array +@vindex calendar-day-abbrev-array Dates can also have the form @samp{@var{monthname} @var{day}} or @samp{@var{monthname} @var{day}, @var{year}}, where the month's name can be spelled in full or abbreviated (with or without a period). The @@ -1194,6 +1230,7 @@ significant. @node Adding to Diary @subsection Commands to Add to the Diary +@cindex create diary entries While in the calendar, there are several commands to create diary entries. The basic commands are listed here; more sophisticated @@ -1219,10 +1256,11 @@ Add a diary entry for the selected day of the year (@code{diary-insert-yearly-en @kindex i d @r{(Calendar mode)} @findex diary-insert-entry - You can make a diary entry for a specific date by selecting that date -in the calendar window and typing the @kbd{i d} command. This command -displays the end of your diary file in another window and inserts the -date; you can then type the rest of the diary entry. + You can make a diary entry for a specific date by selecting that +date in the calendar window and typing the @kbd{i d} +(@code{diary-insert-entry}) command. This command displays the end of +your diary file in another window and inserts the date; you can then +type the rest of the diary entry. @kindex i w @r{(Calendar mode)} @findex diary-insert-weekly-entry @@ -1231,12 +1269,14 @@ date; you can then type the rest of the diary entry. @kindex i y @r{(Calendar mode)} @findex diary-insert-yearly-entry If you want to make a diary entry that applies to a specific day of -the week, select that day of the week (any occurrence will do) and type -@kbd{i w}. This inserts the day-of-week as a generic date; you can then -type the rest of the diary entry. You can make a monthly diary entry in -the same fashion: select the day of the month, use the @kbd{i m} -command, and type the rest of the entry. Similarly, you can insert a -yearly diary entry with the @kbd{i y} command. +the week, select that day of the week (any occurrence will do) and +type @kbd{i w} (@code{diary-insert-weekly-entry}). This inserts the +day-of-week as a generic date; you can then type the rest of the diary +entry. You can make a monthly diary entry in the same fashion: select +the day of the month, use the @kbd{i m} +(@code{diary-insert-monthly-entry}) command, and type the rest of the +entry. Similarly, you can insert a yearly diary entry with the @kbd{i +y} (@code{diary-insert-yearly-entry}) command. All of the above commands make marking diary entries by default. To make a nonmarking diary entry, give a prefix argument to the command. @@ -1251,6 +1291,7 @@ calendar window, if appropriate. You can use the command @node Special Diary Entries @subsection Special Diary Entries +@cindex sexp entries, in diary In addition to entries based on calendar dates, the diary file can contain @dfn{sexp entries} for regular events such as anniversaries. These entries are based on Lisp expressions (sexps) that Emacs evaluates @@ -1276,11 +1317,12 @@ Add a cyclic diary entry starting at the date @kindex i a @r{(Calendar mode)} @findex diary-insert-anniversary-entry - If you want to make a diary entry that applies to the anniversary of a -specific date, move point to that date and use the @kbd{i a} command. -This displays the end of your diary file in another window and inserts -the anniversary description; you can then type the rest of the diary -entry. The entry looks like this: + If you want to make a diary entry that applies to the anniversary of +a specific date, move point to that date and use the @kbd{i a} +(@code{diary-insert-anniversary-entry}) command. This displays the +end of your diary file in another window and inserts the anniversary +description; you can then type the rest of the diary entry. The entry +looks like this: @findex diary-anniversary @example @@ -1294,6 +1336,7 @@ calendar style, the input order of month, day and year is different.) The reason this expression requires a beginning year is that advanced diary functions can use it to calculate the number of elapsed years. +@cindex block diary entry A @dfn{block} diary entry applies to a specified range of consecutive dates. Here is a block diary entry that applies to all dates from June 24, 2012 through July 10, 2012: @@ -1310,17 +1353,19 @@ calendar style, the input order of month, day and year is different.) @kindex i b @r{(Calendar mode)} @findex diary-insert-block-entry - To insert a block entry, place point and the mark on the two -dates that begin and end the range, and type @kbd{i b}. This command -displays the end of your diary file in another window and inserts the -block description; you can then type the diary entry. + To insert a block entry, place point and the mark on the two dates +that begin and end the range, and type @kbd{i b} +(@code{diary-insert-block-entry}). This command displays the end of +your diary file in another window and inserts the block description; +you can then type the diary entry. @kindex i c @r{(Calendar mode)} @findex diary-insert-cyclic-entry - @dfn{Cyclic} diary entries repeat after a fixed interval of days. To -create one, select the starting date and use the @kbd{i c} command. The -command prompts for the length of interval, then inserts the entry, -which looks like this: +@cindex cyclic diary entry + @dfn{Cyclic} diary entries repeat after a fixed interval of days. +To create one, select the starting date and use the @kbd{i c} +(@code{diary-insert-cyclic-entry}) command. The command prompts for +the length of interval, then inserts the entry, which looks like this: @findex diary-cyclic @example @@ -1342,6 +1387,7 @@ since every date visible in the calendar window must be individually checked. So it's a good idea to make sexp diary entries nonmarking (with @samp{&}) when possible. +@cindex floating diary entry Another sophisticated kind of sexp entry, a @dfn{floating} diary entry, specifies a regularly occurring event by offsets specified in days, weeks, and months. It is comparable to a crontab entry interpreted by @@ -1477,6 +1523,7 @@ appointment list with @kbd{M-x appt-delete}. @node Importing Diary @subsection Importing and Exporting Diary Entries +@cindex importing diary entries You can transfer diary entries between Emacs diary files and a variety of other formats. @@ -1534,6 +1581,7 @@ to the main diary file, if these are different files. @findex icalendar-export-file @findex icalendar-export-region +@cindex export diary Use @code{icalendar-export-file} to interactively export an entire Emacs diary file to iCalendar format. To export only a part of a diary file, mark the relevant area, and call @code{icalendar-export-region}. diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index ccdeef414e2..5ede7def2c0 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -569,9 +569,10 @@ Emacs carefully copies the old contents to another file, called the @dfn{backup} file, before actually saving. Emacs makes a backup for a file only the first time the file is -saved from a buffer. No matter how many times you subsequently save -the file, its backup remains unchanged. However, if you kill the -buffer and then visit the file again, a new backup file will be made. +saved from the buffer that visits it. No matter how many times you +subsequently save the file, its backup remains unchanged. However, if +you kill the buffer and then visit the file again, a new backup file +will be made. For most files, the variable @code{make-backup-files} determines whether to make backup files. On most operating systems, its default diff --git a/doc/emacs/input.texi b/doc/emacs/input.texi index 67679b00e89..b553c0895cd 100644 --- a/doc/emacs/input.texi +++ b/doc/emacs/input.texi @@ -126,27 +126,26 @@ minibuffer being brought into use (@pxref{Minibuffer}). @vindex touch-screen-set-point-commands When a ``tap'' gesture results in a command being executed, Emacs -checks whether the command is meant to set the point by searching for -it in the list @code{touch-screen-set-point-commands}. If it is and -the text beneath the new point is not read-only, it activates the -virtual keyboard, in anticipation that the user is about to enter text -there. +checks whether the command is meant to set the point by searching for it +in the list @code{touch-screen-set-point-commands}. If it is, and the +text beneath the new point is not read-only, the virtual keyboard is +activated, in anticipation of the user input there. - The default value of @code{touch-screen-set-point-commands} holds -only the command @code{mouse-set-point} (@pxref{Mouse Commands}), -which is the default binding of @code{mouse-1}, and thus of -touchscreen tap gestures as well. + The default value of @code{touch-screen-set-point-commands} holds only +the command @code{mouse-set-point} (@pxref{Mouse Commands}), which is +the default binding of @code{mouse-1}, and therefore of touchscreen tap +gestures as well. @vindex touch-screen-display-keyboard - The user option @code{touch-screen-display-keyboard} compels Emacs -to display the virtual keyboard on such taps even if the text is read -only; it may also be set buffer locally, in which case Emacs will -always display the keyboard in response to a tap on a window -displaying the buffer it is set in. + The user option @code{touch-screen-display-keyboard} compels Emacs to +display the virtual keyboard on all tap gestures even if the text is +read only; it may also be set buffer locally, in which case Emacs will +always display the keyboard in response to a tap on a window displaying +the buffer it is set in. - There are moreover several functions to show or hide the on-screen -keyboard. For more details, @xref{On-Screen Keyboards,,, elisp, The -Emacs Lisp Reference Manual}. + There are moreover several functions that display or hide the +on-screen keyboard. For more details, @xref{On-Screen Keyboards,,, +elisp, The Emacs Lisp Reference Manual}. @cindex quitting, without a keyboard Since it may not be possible for Emacs to display the virtual @@ -156,9 +155,11 @@ which two rapid clicks of a hardware button that is always present on the device induces a quit. @xref{Quitting}. @vindex x-quit-keysym - No such button is enabled on X, but one can be configured through -the variable @code{x-quit-keysym}. On Android this button is always -the volume down button. +@vindex android-quit-keycode + No such button is enabled on X, but one can be configured through the +variable @code{x-quit-keysym}, whereas the default key is the volume +down button on Android, which is also configurable through a variable, +@code{android-quit-keycode}. @cindex text conversion, keyboards Most input methods designed to work with virtual keyboards edit text diff --git a/doc/emacs/kmacro.texi b/doc/emacs/kmacro.texi index e30def34475..4a8d4d4f093 100644 --- a/doc/emacs/kmacro.texi +++ b/doc/emacs/kmacro.texi @@ -42,6 +42,8 @@ intelligent or general. For such things, Lisp must be used. * Edit Keyboard Macro:: Editing keyboard macros. * Keyboard Macro Step-Edit:: Interactively executing and editing a keyboard macro. +* Kmacro Menu:: An interface for listing and editing + keyboard macros and the keyboard macro ring. @end menu @node Basic Keyboard Macro @@ -616,3 +618,163 @@ including the final @kbd{C-j}), and appends them at the end of the keyboard macro; it then terminates the step-editing and replaces the original keyboard macro with the edited macro. @end itemize + +@node Kmacro Menu +@section Listing and Editing Keyboard Macros +@cindex Kmacro Menu + +@cindex listing current keyboard macros +@kindex M-x list-keyboard-macros @key{RET} +@findex kmacro-menu +@findex list-keyboard-macros + To display a list of existing keyboard macros, type @kbd{M-x +list-keyboard-macros @key{RET}}. This pops up the @dfn{Kmacro Menu} in +a buffer named @file{*Keyboard Macro List*}. Each line in the list +shows one macro's position, counter value, counter format, that counter +value using that format, and macro keys. Here is an example of a macro +list: + +@smallexample +Position Counter Format Formatted Keys +0 8 %02d 08 N : SPC <F3> RET +1 0 %d 0 l o n g SPC p h r a s e +@end smallexample + +@noindent +The macros are listed with the current macro at the top in position +number zero and the older macros in the order in which they are found in +the keyboard macro ring (@pxref{Keyboard Macro Ring}). Using the Kmacro +Menu, you can change the order of the macros and change their counters, +counter formats, and keys. The Kmacro Menu is a read-only buffer, and +can be changed only through the special commands described in this +section. After a command is run, the Kmacro Menu displays changes to +reflect the new values of the macro properties and the macro ring. You +can use the usual cursor motion commands in this buffer, as well as +special motion commands for navigating the table. To view a list of the +special commands, type @kbd{C-h m} or @kbd{?} (@code{describe-mode}) in +the Kmacro Menu. + + You can use the following commands to change a macro's properties: + +@table @kbd +@item # +@findex kmacro-menu-edit-position +@kindex # @r{(Kmacro Menu)} +Change the position of the macro on the current line +(@pxref{Keyboard Macro Ring}). + +@item C-x C-t +@findex kmacro-menu-transpose +@kindex C-x C-t @r{(Kmacro Menu)} +Move the macro on the current line to the line above, like in +@code{transpose-lines}. + +@item c +@findex kmacro-menu-edit-counter +@kindex c @r{(Kmacro Menu)} +Change the counter value of the macro on the current line +(@pxref{Keyboard Macro Counter}). + +@item f +@findex kmacro-menu-edit-format +@kindex f @r{(Kmacro Menu)} +Change the counter format of the macro on the current line. + +@item e +@findex kmacro-menu-edit-keys +@kindex e @r{(Kmacro Menu)} +Change the keys of the macro on the current line using +@code{edit-kbd-macro} (@pxref{Edit Keyboard Macro}). + +@item @key{RET} +@findex kmacro-menu-edit-column +@kindex @key{RET} @r{(Kmacro Menu)} +Change the value in the current column of the macro on the current line +using commands above. +@end table + + The following commands delete or duplicate macros in the list: + +@table @kbd +@item d +@findex kmacro-menu-flag-for-deletion +@item d @r{(Kmacro Menu)} +Flag the macro on the current line for deletion, then move point to the +next line (@code{kmacro-menu-flag-for-deletion}). The deletion flag is +indicated by the character @samp{D} at the start of line. The deletion +occurs only when you type the @kbd{x} command (see below). + + If the region is active, this command flags all of the macros in the +region. + +@item x +@findex kmacro-menu-do-flagged-delete +@item x @r{(Kmacro Menu)} +Delete the macros in the list that have been flagged for deletion +(@code{kmacro-menu-do-flagged-delete}). + +@item m +@findex kmacro-menu-mark +@item m @r{(Kmacro Menu)} +Mark the macro on the current line, then move point to the next line +(@code{kmacro-menu-mark}). Marked macros are indicated by the character +@samp{*} at the start of line. Marked macros can be operated on by the +@kbd{C} and @kbd{D} commands (see below). + + If the region is active, this command marks all of the macros in the +region. + +@item C +@findex kmacro-menu-do-copy +@item C @r{(Kmacro Menu)} +This command copies macros by duplicating them at their current +positions in the list (@code{kmacro-menu-do-copy}). For example, +running this command on the macro at position number zero will insert a +copy of that macro into position number one and move the remaining +macros down. + + If the region is active, this command duplicates the macros in the +region. Otherwise, if there are marked macros, this command duplicates +the marked macros. If there is no region nor are there marked macros, +this command duplicates the macro on the current line. In the first two +cases, the command prompts for confirmation before duplication. + +@item D +@findex kmacro-menu-do-delete +@item D @r{(Kmacro Menu)} +This command deletes macros, removing them from the ring +(@code{kmacro-menu-do-delete}). For example, running this command on +the macro at position number zero will delete the current macro and then +make the first macro in the macro ring (previously at position number +one) the new current macro, popping it from the ring. + + If the region is active, this command deletes the macros in the +region. Otherwise, if there are marked macros, this command deletes the +marked macros. If there is no region nor are there marked macros, this +command deletes the macro on the current line. In all cases, the +command prompts for confirmation before deletion. + + This command is an alternative to the @kbd{d} and @kbd{x} commands +(see above). + +@item u +@findex kmacro-menu-unmark +@item u @r{(Kmacro Menu)} +Unmark and unflag the macro on the current line, then move point down +to the next line (@code{kmacro-menu-unmark}). If there is an active +region, this command unmarks and unflags all of the macros in the +region. + +@item @key{DEL} +@findex kmacro-menu-unmark-backward +@item @key{DEL} @r{(Kmacro Menu)} +Like the @kbd{u} command (see above), but move point up to the previous +line when there is no active region +(@code{kmacro-menu-unmark-backward}). + +@item U +@findex kmacro-menu-unmark-all +@item U @r{(Kmacro Menu)} +Unmark and unflag all macros in the list +(@code{kmacro-menu-unmark-all}). +@end table diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index d3e06fa697b..579098c81b1 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2343,19 +2343,33 @@ documentation for details. @vindex xref-auto-jump-to-first-definition If any of the above commands finds more than one matching definition, it by default pops up the @file{*xref*} buffer showing the -matching candidates. (@kbd{C-M-.}@: @emph{always} pops up the -@file{*xref*} buffer if it finds at least one match.) The candidates -are normally shown in that buffer as the name of a file and the -matching identifier(s) in that file. In that buffer, you can select -any of the candidates for display, and you have several additional -commands, described in @ref{Xref Commands}. However, if the value of -the variable @code{xref-auto-jump-to-first-definition} is @code{move}, -the first of these candidates is automatically selected in the -@file{*xref*} buffer, and if it's @code{t} or @code{show}, the first -candidate is automatically shown in its own window; @code{t} also -selects the window showing the first candidate. The default value is -@code{nil}, which just shows the candidates in the @file{*xref*} -buffer, but doesn't select any of them. +matching candidates and selects that buffer's window. (@kbd{C-M-.}@: +@emph{always} pops up the @file{*xref*} buffer if it finds at least +one match.) Each candidate is normally shown in that buffer as the +name of a file and the matching identifier(s) in that file. In that +buffer, you can select any of the candidates for display, and you have +several additional commands, described in @ref{Xref Commands}. +However, if the value of the variable +@code{xref-auto-jump-to-first-definition} is @code{move}, Emacs +automatically moves point to the first of these candidates in the +@file{*xref*} buffer, so just typing @key{RET} will display the +definition of that candidate. If the value of the variable is +@code{t} or @code{show}, the first candidate is automatically shown in +its own window; @code{t} also selects the window showing the first +candidate's definition, while @code{show} leaves the window of the +@file{*xfer*} buffer selected. The default value is @code{nil}, which +just shows the candidates in the @file{*xref*} buffer, but neither +selects any of them nor shows their definition, until you select a +candidate in the @file{*xref*} buffer. + +@findex next-error, in @file{*xref*} buffer +@findex previous-error, in @file{*xref*} buffer +@kindex M-g M-n, for navigation in @file{*xref*} buffer +@kindex M-g M-p, for navigation in @file{*xref*} buffer + If you switch away of the window showing the @file{*xref*} buffer +which displays several candidates, you can move from one candidate to +another using the commands @w{@kbd{M-g M-n}} (@code{next-error}) and +@w{@kbd{M-g M-p}} (@code{previous-error}). @xref{Compilation Mode}. @kindex M-, @findex xref-go-back @@ -2518,12 +2532,17 @@ referenced. The XREF mode commands are available in this buffer, see @vindex xref-auto-jump-to-first-xref If the value of the variable @code{xref-auto-jump-to-first-xref} is @code{t}, @code{xref-find-references} automatically jumps to the first -result and selects the window where it is displayed. If the value is -@code{show}, the first result is shown, but the window showing the +result in the @file{*xref*} buffer and selects the window where that +reference is displayed; you can select the other results with +@w{@kbd{M-g M-n}} (@code{next-error}) and @w{@kbd{M-g M-p}} +(@code{previous-error}) (@pxref{Compilation Mode}). If the value is +@code{show}, the first result is displayed, but the window showing the @file{*xref*} buffer is left selected. If the value is @code{move}, the first result is selected in the @file{*xref*} buffer, but is not -shown. The default value is @code{nil}, which just shows the results -in the @file{*xref*} buffer, but doesn't select any of them. +displayed; you can then use @key{RET} to actually display the +reference. The default value is @code{nil}, which just shows the +results in the @file{*xref*} buffer, but doesn't select any of them, +and doesn't display the reference itself. @findex xref-query-replace-in-results @kbd{r} (@code{xref-query-replace-in-results}) reads a @var{replacement} @@ -3374,29 +3393,30 @@ merge requests resulting in different URLs. @vindex bug-reference-auto-setup-functions If @code{bug-reference-mode} is activated, -@code{bug-reference-mode-hook} has been run and still -@code{bug-reference-bug-regexp}, and @code{bug-reference-url-format} -aren't both set, it'll try to setup suitable values for these two -variables itself by calling the functions in -@code{bug-reference-auto-setup-functions} one after the other until -one is able to set the variables. +@code{bug-reference-mode-hook} has been run, and either +@code{bug-reference-bug-regexp} or @code{bug-reference-url-format} is +still @code{nil}, the mode will try to automatically find a suitable +value for these two variables by calling the functions in +@code{bug-reference-auto-setup-functions} one by one until one +succeeds. @vindex bug-reference-setup-from-vc-alist @vindex bug-reference-forge-alist @vindex bug-reference-setup-from-mail-alist @vindex bug-reference-setup-from-irc-alist - Right now, there are three types of setup functions. +Right now, there are three types of setup functions. + @enumerate @item Setup for version-controlled files configurable by the variables @code{bug-reference-forge-alist}, and @code{bug-reference-setup-from-vc-alist}. The defaults are able to -setup GNU projects where @url{https://debbugs.gnu.org} is used as +set up GNU projects where @url{https://debbugs.gnu.org} is used as issue tracker and issues are usually referenced as @code{bug#13} (but -many different notations are considered, too), and several kinds of -modern software forges such as GitLab, Gitea, SourceHut, or GitHub. -If you deploy a self-hosted instance of such a forge, the easiest way -to tell bug-reference about it is through +many different notations are considered, too), as well as several +other kinds of software forges such as GitLab, Gitea, SourceHut, and +GitHub. If you deploy a self-hosted instance of such a forge, the +easiest way to tell bug-reference about it is through @code{bug-reference-forge-alist}. @item @@ -3413,7 +3433,7 @@ Rcirc, @xref{Top, Rcirc,, rcirc, The Rcirc Manual}, and ERC, @end enumerate For almost all of those modes, it's enough to simply enable -@code{bug-reference-mode}, only Rmail requires a slightly different +@code{bug-reference-mode}; only Rmail requires a slightly different setup. @smallexample @@ -3444,33 +3464,35 @@ to be performed whenever another messages is displayed. @heading Adding support for third-party packages @vindex bug-reference-auto-setup-functions -Adding support for bug-reference' auto-setup is usually quite -straight-forward: write a setup function of zero arguments which +Adding support for bug-reference auto-setup is usually quite +straightforward: write a setup function of zero arguments which gathers the required information (e.g., List-Id/To/From/Cc mail header values in the case of a MUA), and then calls one of the following helper functions: + @itemize @bullet @item -@code{bug-reference-maybe-setup-from-vc} which does the setup -according to @code{bug-reference-setup-from-vc-alist}, +@code{bug-reference-maybe-setup-from-vc}, which does the setup +according to @code{bug-reference-setup-from-vc-alist}; @item -@code{bug-reference-maybe-setup-from-mail} which does the setup -according to @code{bug-reference-setup-from-mail-alist}, +@code{bug-reference-maybe-setup-from-mail}, which does the setup +according to @code{bug-reference-setup-from-mail-alist}; and @item -and @code{bug-reference-maybe-setup-from-irc} which does the setup +@code{bug-reference-maybe-setup-from-irc}, which does the setup according to @code{bug-reference-setup-from-irc-alist}. @end itemize -A setup function should return non-@code{nil} if it could setup bug-reference -mode which is the case if the last thing the function does is calling -one of the helper functions above. + +A setup function should return non-@code{nil} if it could set up +bug-reference mode, which is the case if the last thing the function +does is call one of the helper functions above. Finally, the setup function has to be added to @code{bug-reference-auto-setup-functions}. Note that these auto-setup functions should check as a first step if -they are applicable, e.g., by checking the @code{major-mode} value. +they are applicable, e.g., by checking the value of @code{major-mode}. @heading Integration with the debbugs package diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index aa7144610a6..4557f41c3f7 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -353,7 +353,8 @@ arguments that often include spaces, such as file names. Submit the text in the minibuffer as the argument, possibly completing first (@code{minibuffer-complete-and-exit}). @xref{Completion Exit}. @item ? -Display a list of completions (@code{minibuffer-completion-help}). +Display a list of completions and a few useful key bindings +(@code{minibuffer-completion-help}). @end table @kindex TAB @r{(completion)} @@ -375,11 +376,12 @@ all the way to @samp{auto-fill-mode}. @kindex ? @r{(completion)} @cindex completion list - If @key{TAB} or @key{SPC} is unable to complete, it displays a list -of matching completion alternatives (if there are any) in another -window. You can display the same list with @kbd{?} -(@code{minibuffer-completion-help}). The following commands can be -used with the completion list: + If @key{TAB} or @key{SPC} is unable to complete, it displays in +another window a list of matching completion alternatives (if there are +any) and a few useful commands to select a completion candidate. You +can display the same completion list and help with @kbd{?} +(@code{minibuffer-completion-help}). The following commands can be used +with the completion list: @table @kbd @vindex minibuffer-completion-auto-choose diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 8f9ee317080..04e6138b692 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -2166,12 +2166,13 @@ running on a text terminal, it creates a new frame in the current text terminal. @item -T @var{tramp-prefix} -@itemx --tramp-prefix=@var{tramp-prefix} +@itemx --tramp=@var{tramp-prefix} Set the prefix to add to filenames for Emacs to locate files on remote machines (@pxref{Remote Files}) using TRAMP (@pxref{Top, The Tramp Manual,, tramp, The Tramp Manual}). This is mostly useful in -combination with using the Emacs server over TCP (@pxref{TCP Emacs -server}). By ssh-forwarding the listening port and making the +combination with using the Emacs server from a remote host. By +ssh-forwarding the listening socket, or ssh-forwarding the listening +port @pxref{TCP Emacs server} and making the @var{server-file} available on a remote machine, programs on the remote machine can use @command{emacsclient} as the value for the @env{EDITOR} and similar environment variables, but instead of talking @@ -2183,16 +2184,29 @@ Setting the environment variable @env{EMACSCLIENT_TRAMP} has the same effect as using the @samp{-T} option. If both are specified, the command-line option takes precedence. -For example, assume two hosts, @samp{local} and @samp{remote}, and -that the local Emacs listens on tcp port 12345. Assume further that +For example, assume two hosts, @samp{local} and @samp{remote}. + +@example +local$ ssh -R "/home/%r/.emacs.socket":"$@{XDG_RUNTIME_DIR:-$@{TMPDIR:-/tmp@}/emacs%i@}$@{XDG_RUNTIME_DIR:+/emacs@}/server" remote +remote$ export EMACS_SOCKET_NAME=$HOME/.emacs.socket +remote$ export EMACSCLIENT_TRAMP=/ssh:remote: +remote$ export EDITOR=emacsclient +remote$ $EDITOR /tmp/foo.txt #Should open in local emacs. +@end example + +If you are using a platform where @command{emacsclient} does not use +Unix domain sockets (i.e., MS-Windows), or your SSH implementation is +not able to forward them (e.g., OpenSSH before version 6.7), you can +forward a TCP port instead. In this example, assume that the local +Emacs listens on tcp port 12345. Assume further that @file{/home} is on a shared file system, so that the server file @file{~/.emacs.d/server/server} is readable on both hosts. @example local$ ssh -R12345:localhost:12345 remote -remote$ export EDITOR="emacsclient \ - --server-file=server \ - --tramp=/ssh:remote:" +remote$ export EMACS_SERVER_FILE=server +remote$ export EMACSCLIENT_TRAMP=/ssh:remote: +remote$ export EDITOR=emacsclient remote$ $EDITOR /tmp/foo.txt #Should open in local emacs. @end example diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index c8f790bab47..fd445805068 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -490,8 +490,12 @@ startup if invoked with the @samp{-q} or @samp{--no-init-file} options To keep Emacs from automatically making packages available at startup, change the variable @code{package-enable-at-startup} to @code{nil}. You must do this in the early init file, as the variable -is read before loading the regular init file. Currently this variable -cannot be set via Customize. +is read before loading the regular init file. Therefore, if you +customize this variable via Customize, you should save your customized +setting into your early init file. To do this, set or change the value +of the variable @code{custom-file} (@pxref{Saving Customizations}) to +point to your early init file before saving the customized value of +@code{package-enable-at-startup}. @findex package-quickstart-refresh @vindex package-quickstart diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index 1627e7e6cb7..01a1462044c 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -338,10 +338,13 @@ where it treats each chapter, section, etc., as a definition. together.) @findex imenu +@vindex imenu-flatten If you type @kbd{M-g i} (@code{imenu}), it reads the name of a definition using the minibuffer, then moves point to that definition. You can use completion to specify the name; the command always -displays the whole list of valid names. +displays the whole list of valid names. If you set @code{imenu-flatten} +to a non-@code{nil} value, then instead of the nested menu +you can select a completion candidate from the flat list. @findex imenu-add-menubar-index Alternatively, you can bind the command @code{imenu} to a mouse @@ -1706,11 +1709,14 @@ based on the spell-checker's dictionary. @xref{Spelling}. @cindex suggestion preview @cindex Completion Preview mode @findex completion-preview-mode +@findex global-completion-preview-mode Completion Preview mode is a minor mode that shows completion -suggestions as you type. When you enable this mode (with @kbd{M-x -completion-preview-mode}), Emacs automatically displays the -suggested completion for text around point as an in-line preview -right after point; type @key{TAB} to accept the suggestion. +suggestions as you type. You can enable it for the current buffer with +@kbd{M-x completion-preview-mode}, or globally with @w{@kbd{M-x +global-completion-preview-mode}}. When Completion Preview mode is on, +Emacs automatically displays the suggested completion for text around +point as an in-line preview right after point; type @key{TAB} to accept +the suggestion. @node MixedCase Words @section MixedCase Words diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi index cac5b32c566..734d704a272 100644 --- a/doc/emacs/regs.texi +++ b/doc/emacs/regs.texi @@ -380,8 +380,19 @@ Save all the current bookmark values in the default bookmark file. @kbd{C-x r m}, which sets a bookmark using the visited file name as the default for the bookmark name. If you name each bookmark after the file it points to, then you can conveniently revisit any of those -files with @kbd{C-x r b}, and move to the position of the bookmark at -the same time. +files with @kbd{C-x r b} (@code{bookmark-jump}), and move to the +position of the bookmark at the same time. + +@vindex bookmark-fringe-mark + In addition to recording the current position, on graphical displays +@kbd{C-x r m} places a special image on the left fringe +(@pxref{Fringes}) of the screen line corresponding to the recorded +position, to indicate that there's a bookmark there. This can be +controlled by the user option @code{bookmark-fringe-mark}: customize +it to @code{nil} to disable the fringe mark. The default value is +@code{bookmark-mark}, which is the bitmap used for this purpose. When +you later use @kbd{C-x r b} to jump back to the bookmark, the fringe +mark will be again shown on the fringe. @kindex C-x r M @findex bookmark-set-no-overwrite diff --git a/doc/emacs/sending.texi b/doc/emacs/sending.texi index 7d9f4917929..937ee568a3a 100644 --- a/doc/emacs/sending.texi +++ b/doc/emacs/sending.texi @@ -676,9 +676,11 @@ using this. In this chapter we have described the usual Emacs mode for editing and sending mail---Message mode. This is only one of several available modes. Prior to Emacs 23.2, the default mode was Mail mode, -which is similar to Message mode in many respects but lacks features -such as MIME support. Another available mode is MH-E -(@pxref{Top,,MH-E,mh-e, The Emacs Interface to MH}). +which is similar to Message mode in many respects but is less +feature-rich; for example, it supports only basic MIME: it allows you +to add attachments, but lacks more sophisticated MIME features. +Another available mode is MH-E (@pxref{Top,,MH-E,mh-e, The Emacs +Interface to MH}). @vindex mail-user-agent @findex define-mail-user-agent diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index cb347d59948..f5e31fd277f 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -943,12 +943,15 @@ situations where you shouldn't change the major mode---in mail composition, for instance. @kindex M-TAB @r{(Text mode)} +@findex completion-at-point@r{, in Text Mode} +@vindex text-mode-ispell-word-completion The command @kbd{M-@key{TAB}} (@code{completion-at-point}) performs completion of the partial word in the buffer before point, using the spelling dictionary as the space of possible words by default. @xref{Spelling}. If your window manager defines @kbd{M-@key{TAB}} to switch windows, you can type @kbd{@key{ESC} @key{TAB}} or @kbd{C-M-i} -instead. +instead. To disable this completion, customize the variable +@code{text-mode-ispell-word-completion} to the @code{nil} value. @vindex text-mode-hook Entering Text mode runs the mode hook @code{text-mode-hook} diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index a06822ce539..19777bf8ab7 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -19428,7 +19428,7 @@ There is more, but that is the hardest part. @appendixsec The @file{ring.el} File @cindex @file{ring.el} file -Interestingly, GNU Emacs posses a file called @file{ring.el} that +Interestingly, GNU Emacs possesses a file called @file{ring.el} that provides many of the features we just discussed. But functions such as @code{kill-ring-yank-pointer} do not use this library, possibly because they were written earlier. diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in index 0a228271be3..4ceffd7d7d3 100644 --- a/doc/lispref/Makefile.in +++ b/doc/lispref/Makefile.in @@ -112,6 +112,7 @@ srcs = \ $(srcdir)/os.texi \ $(srcdir)/package.texi \ $(srcdir)/parsing.texi \ + $(srcdir)/peg.texi \ $(srcdir)/positions.texi \ $(srcdir)/processes.texi \ $(srcdir)/records.texi \ diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 4fe4969c0db..e743038a778 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -2303,15 +2303,34 @@ touch sequence after it is called. @subsection Focus Events @cindex focus event +This section talks about both window systems and Emacs frames. When +talking about just ``frames'' or ``windows'', it refers to Emacs frames +and Emacs windows. When talking about window system windows, which are +also Emacs frames, this section always says ``window system window''. + +@noindent Window systems provide general ways for the user to control which window -gets keyboard input. This choice of window is called the @dfn{focus}. -When the user does something to switch between Emacs frames, that -generates a @dfn{focus event}. The normal definition of a focus event, -in the global keymap, is to select a new frame within Emacs, as the user -would expect. @xref{Input Focus}, which also describes hooks related -to focus events. +system window, or Emacs frame, gets keyboard input. This choice of +window system window is called the @dfn{focus}. When the user does +something to switch between Emacs frames, that generates a @dfn{focus +event}. Emacs also generates focus events when using +@var{mouse-autoselect-window} to switch between Emacs windows within +Emacs frames. + +A focus event in the middle of a key sequence would garble the +sequence. So Emacs never generates a focus event in the middle of a key +sequence. If the user changes focus in the middle of a key +sequence---that is, after a prefix key---then Emacs reorders the events +so that the focus event comes either before or after the multi-event key +sequence, and not within it. -Focus events are represented in Lisp as lists that look like this: +@subsubheading Focus events for frames + +The normal definition of a focus event that switches frames, in the +global keymap, is to select that new frame within Emacs, as the user +would expect. @xref{Input Focus}, which also describes hooks related to +focus events for frames. Focus events for frames are represented in +Lisp as lists that look like this: @example (switch-frame @var{new-frame}) @@ -2321,19 +2340,28 @@ Focus events are represented in Lisp as lists that look like this: where @var{new-frame} is the frame switched to. Some X window managers are set up so that just moving the mouse into a -window is enough to set the focus there. Usually, there is no need -for a Lisp program to know about the focus change until some other -kind of input arrives. Emacs generates a focus event only when the -user actually types a keyboard key or presses a mouse button in the -new frame; just moving the mouse between frames does not generate a -focus event. +frame is enough to set the focus there. Usually, there is no need for a +Lisp program to know about the focus change until some other kind of +input arrives. Emacs generates a focus event only when the user +actually types a keyboard key or presses a mouse button in the new +frame; just moving the mouse between frames does not generate a focus +event. -A focus event in the middle of a key sequence would garble the -sequence. So Emacs never generates a focus event in the middle of a key -sequence. If the user changes focus in the middle of a key -sequence---that is, after a prefix key---then Emacs reorders the events -so that the focus event comes either before or after the multi-event key -sequence, and not within it. +@subsubheading Focus events for windows + +When @var{mouse-autoselect-window} is set, moving the mouse over a new +window within a frame can also switch the selected window. @xref{Mouse +Window Auto-selection}, which describes the behavior for different +values. When the mouse is moved over a new window, a focus event for +switching windows is generated. Focus events for windows are +reperesented in Lisp as lists that look like this: + +@example +(select-window @var{new-window}) +@end example + +@noindent +where @var{new-window} is the window switched to. @node Xwidget Events @subsection Xwidget events @@ -3735,7 +3763,10 @@ character as far as keyboard translation is concerned, but it has the same usual meaning. @xref{Translation Keymaps}, for mechanisms that translate event sequences -at the level of @code{read-key-sequence}. +at the level of @code{read-key-sequence}. If you need to translate +input events that are not characters (i.e., @code{characterp} returns +@code{nil} for them), you must use the event translation mechanism +described there. @node Invoking the Input Method @subsection Invoking the Input Method diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi index 00602198da5..19451f31740 100644 --- a/doc/lispref/compile.texi +++ b/doc/lispref/compile.texi @@ -37,7 +37,7 @@ variable binding for @code{no-byte-compile} into it, like this: * Docs and Compilation:: Dynamic loading of documentation strings. * Eval During Compile:: Code to be evaluated when you compile. * Compiler Errors:: Handling compiler error messages. -* Byte-Code Objects:: The data type used for byte-compiled functions. +* Closure Objects:: The data type used for byte-compiled functions. * Disassembly:: Disassembling byte-code; how to read byte-code. @end menu @@ -120,7 +120,7 @@ replacing the previous definition with the compiled one. The function definition of @var{symbol} must be the actual code for the function; @code{byte-compile} does not handle function indirection. The return value is the byte-code function object which is the compiled -definition of @var{symbol} (@pxref{Byte-Code Objects}). +definition of @var{symbol} (@pxref{Closure Objects}). @example @group @@ -334,8 +334,8 @@ If you have a constant that needs some calculation to produce, @code{eval-when-compile} can do that at compile-time. For example, @lisp -(defvar my-regexp - (eval-when-compile (regexp-opt '("aaa" "aba" "abb")))) +(defvar gauss-schoolboy-problem + (eval-when-compile (apply #'+ (number-sequence 1 100)))) @end lisp @cindex macros, at compile time @@ -487,21 +487,22 @@ string for details. using @code{error}. If so, set @code{byte-compile-error-on-warn} to a non-@code{nil} value. -@node Byte-Code Objects -@section Byte-Code Function Objects +@node Closure Objects +@section Closure Function Objects @cindex compiled function @cindex byte-code function @cindex byte-code object - Byte-compiled functions have a special data type: they are -@dfn{byte-code function objects}. Whenever such an object appears as -a function to be called, Emacs uses the byte-code interpreter to -execute the byte-code. + Byte-compiled functions use a special data type: they are closures. +Closures are used both for byte-compiled Lisp functions as well as for +interpreted Lisp functions. Whenever such an object appears as +a function to be called, Emacs uses the appropriate interpreter to +execute either the byte-code or the non-compiled Lisp code. - Internally, a byte-code function object is much like a vector; its + Internally, a closure is much like a vector; its elements can be accessed using @code{aref}. Its printed representation is like that for a vector, with an additional @samp{#} -before the opening @samp{[}. It must have at least four elements; +before the opening @samp{[}. It must have at least three elements; there is no maximum number, but only the first six elements have any normal use. They are: @@ -515,20 +516,28 @@ zero to 6, and the maximum number of arguments in bits 8 to 14. If the argument list uses @code{&rest}, then bit 7 is set; otherwise it's cleared. -If @var{argdesc} is a list, the arguments will be dynamically bound +When the closure is a byte-code function, +if @var{argdesc} is a list, the arguments will be dynamically bound before executing the byte code. If @var{argdesc} is an integer, the arguments will be instead pushed onto the stack of the byte-code interpreter, before executing the code. -@item byte-code -The string containing the byte-code instructions. +@item code +For interpreted functions, this element is the (non-empty) list of Lisp +forms that make up the function's body. For byte-compiled functions, it +is the string containing the byte-code instructions. @item constants -The vector of Lisp objects referenced by the byte code. These include -symbols used as function names and variable names. +For byte-compiled functions, this holds the vector of Lisp objects +referenced by the byte code. These include symbols used as function +names and variable names. +For interpreted functions, this is @code{nil} if the function is using the old +dynamically scoped dialect of Emacs Lisp, and otherwise it holds the +function's lexical environment. @item stacksize -The maximum stack size this function needs. +The maximum stack size this function needs. This element is left unused +for interpreted functions. @item docstring The documentation string (if any); otherwise, @code{nil}. The value may @@ -558,8 +567,8 @@ representation. It is the definition of the command @code{make-byte-code}: @defun make-byte-code &rest elements -This function constructs and returns a byte-code function object -with @var{elements} as its elements. +This function constructs and returns a closure which represents the +byte-code function object with @var{elements} as its elements. @end defun You should not try to come up with the elements for a byte-code @@ -567,6 +576,20 @@ function yourself, because if they are inconsistent, Emacs may crash when you call the function. Always leave it to the byte compiler to create these objects; it makes the elements consistent (we hope). +The primitive way to create an interpreted function is with +@code{make-interpreted-closure}: + +@defun make-interpreted-closure args body env &optional docstring iform +This function constructs and returns a closure representing the +interpreted function with arguments @var{args} and whose body is made of +@var{body} which must be a non-@code{nil} list of Lisp forms. @var{env} is the +lexical environment in the same form as used with @code{eval} +(@pxref{Eval}). The documentation @var{docstring} if non-@code{nil} should be +a string, and the interactive form @var{iform} if non-@code{nil} should be of +the form @w{@code{(interactive @var{arg-descriptor})}} (@pxref{Using +Interactive}). +@end defun + @node Disassembly @section Disassembled Byte-Code @cindex disassembled byte-code @@ -595,7 +618,7 @@ name of an existing buffer. Then the output goes there, at point, and point is left before the output. The argument @var{object} can be a function name, a lambda expression -(@pxref{Lambda Expressions}), or a byte-code object (@pxref{Byte-Code +(@pxref{Lambda Expressions}), or a byte-code object (@pxref{Closure Objects}). If it is a lambda expression, @code{disassemble} compiles it and disassembles the resulting compiled code. @end deffn diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index f9f3389c398..8b74b7cec5b 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -350,7 +350,8 @@ kinds of multiple conditional constructs. This function tests for the falsehood of @var{condition}. It returns @code{t} if @var{condition} is @code{nil}, and @code{nil} otherwise. The function @code{not} is identical to @code{null}, and we recommend -using the name @code{null} if you are testing for an empty list. +using the name @code{null} if you are testing for an empty list or +@code{nil} value. @end defun @defspec and conditions@dots{} @@ -2411,7 +2412,7 @@ point where we signaled the original error: @group Debugger entered--Lisp error: (error "Oops") signal(error ("Oops")) - (closure (t) (err) (signal 'error (cdr err)))((user-error "Oops")) + #f(lambda (err) [t] (signal 'error (cdr err)))((user-error "Oops")) user-error("Oops") @dots{} eval((handler-bind ((user-error (lambda (err) @dots{} diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index b497967c445..011738df268 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2685,12 +2685,17 @@ Underline in color @var{color}, a string specifying a color. @var{color} is either a string, or the symbol @code{foreground-color}, meaning the foreground color of the face. Omitting the attribute @code{:color} means to use the foreground color of the face. -@var{style} should be a symbol @code{line} or @code{wave}, meaning to -use a straight or wavy line. Omitting the attribute @code{:style} -means to use a straight line. @var{position}, if non-@code{nil}, means to -display the underline at the descent of the text, instead of at the -baseline level. If it is a number, then it specifies the amount of -pixels above the descent to display the underline. +@var{style} is a symbol which sets the line-style to of the underline. +It should be one of @code{line}, @code{double-line}, @code{wave}, +@code{dots}, or @code{dashes}. GUI frames under most window systems +support all the aforementioned underline styles, while on text terminals +@code{double-line}, @code{wave} and @code{dots} are contingent on the +availability of the @code{Smulx} or @code{Su} terminfo capabilities. +Omitting the attribute @code{:style} means to use a straight line. +@var{position}, if non-@code{nil}, means to display the underline at the +descent of the text, instead of at the baseline level. If it is a +number, then it specifies the amount of pixels above the descent to +display the underline. @end table @cindex overlined text @@ -5501,6 +5506,10 @@ specification. The optional @var{face} specifies the face whose colors are to be used for the bitmap display. @xref{Fringe Bitmaps}, for the details. +It also possible to add context help for fringe bitmaps through the +@code{show-help-function} mechanism by using @code{left-fringe-help} and +@code{right-fringe-help} text properties (@pxref{Special Properties}). + @item (space-width @var{factor}) This display specification affects all the space characters within the text that has the specification. It displays all of these spaces @@ -5788,8 +5797,11 @@ either an integer, which represents the dimension in pixels, or a pair length in @dfn{ems}@footnote{In typography an em is a distance equivalent to the height of the type. For example when using 12 point type 1 em is equal to 12 points. Its use ensures distances and type -remain proportional.}. One em is equivalent to the height of the font -and @var{value} may be an integer or a float. +remain proportional.}. One em is equivalent to the size of the font +and @var{value} may be an integer or a float. Also, dimension can be +specified in @code{(@var{value} . ch)} and @code{(@var{value} . cw)} +forms, where @code{ch} means height of the canonical character and +@code{cw} means width of the canonical character. The following is a list of properties that are meaningful for all image types (there are also properties which are meaningful only for diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 71139db4359..339272d1f05 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -222,6 +222,7 @@ To view this manual in other formats, click * Non-ASCII Characters:: Non-ASCII text in buffers and strings. * Searching and Matching:: Searching buffers for strings or regexps. * Syntax Tables:: The syntax table controls word and list parsing. +* Parsing Expression Grammars:: Parsing structured buffer text. * Parsing Program Source:: Generate syntax tree for program sources. * Abbrevs:: How Abbrev mode works, and its data structures. @@ -322,7 +323,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Closure Type:: A function written in Lisp, then compiled. * Record Type:: Compound objects with programmer-defined types. * Type Descriptors:: Objects holding information about types. * Autoload Type:: A type used for automatically loading seldom-used @@ -656,7 +657,7 @@ Byte Compilation * Docs and Compilation:: Dynamic loading of documentation strings. * Eval During Compile:: Code to be evaluated when you compile. * Compiler Errors:: Handling compiler error messages. -* Byte-Code Objects:: The data type used for byte-compiled functions. +* Closure Objects:: The data type used for byte-compiled functions. * Disassembly:: Disassembling byte-code; how to read byte-code. Native Compilation @@ -1365,6 +1366,12 @@ Syntax Tables * Syntax Table Internals:: How syntax table information is stored. * Categories:: Another way of classifying character syntax. +Parsing Expression Grammars + +* PEX Definitions:: The syntax of PEX rules +* Parsing Actions:: Running actions upon successful parsing. +* Writing PEG Rules:: Tips for writing parsing rules. + Parsing Program Source * Language Grammar:: Loading tree-sitter language grammar. @@ -1720,6 +1727,7 @@ Object Internals @include searching.texi @include syntax.texi +@include peg.texi @include parsing.texi @include abbrevs.texi @include threads.texi diff --git a/doc/lispref/elisp_type_hierarchy.jpg b/doc/lispref/elisp_type_hierarchy.jpg Binary files differindex 386954e1007..6559ef8bf9b 100644 --- a/doc/lispref/elisp_type_hierarchy.jpg +++ b/doc/lispref/elisp_type_hierarchy.jpg diff --git a/doc/lispref/elisp_type_hierarchy.txt b/doc/lispref/elisp_type_hierarchy.txt index bb93cd831b9..08ce0603243 100644 --- a/doc/lispref/elisp_type_hierarchy.txt +++ b/doc/lispref/elisp_type_hierarchy.txt @@ -1,33 +1,33 @@ | Type | Derived Types | |---------------------+-----------------------------------------------------------| -| t | sequence atom | -| atom | number-or-marker array record symbol function | -| | window-configuration font-object font-entity mutex | -| | tree-sitter-node buffer overlay tree-sitter-parser thread | -| | font-spec native-comp-unit tree-sitter-compiled-query | -| | terminal window frame hash-table user-ptr obarray condvar | -| | process | -| sequence | array list | -| list | null cons | -| function | oclosure compiled-function module-function | -| | interpreted-function | -| symbol | boolean symbol-with-pos keyword | -| compiled-function | subr byte-code-function | -| oclosure | accessor advice--forward cconv--interactive-helper | -| | cl--generic-nnm advice save-some-buffers-function | -| record | cl-structure-object | -| cl-structure-object | cl--class lisp-indent-state cl--random-state registerv | -| | xref-elisp-location isearch--state cl-slot-descriptor | -| | cl--generic-generalizer uniquify-item cl--generic-method | -| | register-preview-info cl--generic | -| cons | ppss decoded-time | -| array | vector string char-table bool-vector | -| number-or-marker | number integer-or-marker | -| integer-or-marker | integer marker | -| number | integer float | -| cl--class | built-in-class cl-structure-class oclosure--class | -| subr | subr-native-elisp subr-primitive | -| accessor | oclosure-accessor | -| vector | timer | | boolean | null | | integer | fixnum bignum | +| accessor | oclosure-accessor | +| cl--class | cl-structure-class oclosure--class built-in-class | +| vector | timer | +| cons | ppss decoded-time | +| number | integer float | +| integer-or-marker | integer marker | +| number-or-marker | number integer-or-marker | +| array | vector string bool-vector char-table | +| oclosure | accessor advice cconv--interactive-helper advice--forward | +| | save-some-buffers-function cl--generic-nnm | +| cl-structure-object | cl--class xref-elisp-location org-cite-processor | +| | cl--generic-method cl--random-state register-preview-info | +| | cl--generic cl-slot-descriptor uniquify-item registerv | +| | isearch--state cl--generic-generalizer lisp-indent-state | +| record | cl-structure-object | +| symbol | boolean symbol-with-pos | +| subr | primitive-function subr-native-elisp special-form | +| compiled-function | primitive-function subr-native-elisp byte-code-function | +| function | oclosure compiled-function interpreted-function | +| | module-function | +| list | null cons | +| sequence | array list | +| atom | number-or-marker array record symbol subr function mutex | +| | font-spec frame tree-sitter-compiled-query | +| | tree-sitter-node font-entity finalizer tree-sitter-parser | +| | hash-table window-configuration user-ptr overlay process | +| | font-object obarray condvar buffer terminal thread window | +| | native-comp-unit | +| t | sequence atom | diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index cf7fc7721c5..cae93acae9f 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -2823,6 +2823,18 @@ direction. See also @code{next-window} and @code{previous-window}, in @ref{Cyclic Window Ordering}. + Some Lisp programs need to find one or more frames that satisfy a +given criteria. The function @code{filtered-frame-list} is provided for +this purpose. + +@defun filtered-frame-list predicate +This function returns the list of all the live frames which satisfy the +specified @var{predicate}. The argument @var{predicate} must be a +function of one argument, a frame to be tested against the filtering +criteria, and should return non-@code{nil} if the frame satisfies the +criteria. +@end defun + @node Minibuffers and Frames @section Minibuffers and Frames diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index ff635fc54b2..a77bf6e233d 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -130,7 +130,7 @@ it also encloses an environment of lexical variable bindings. @item byte-code function A function that has been compiled by the byte compiler. -@xref{Byte-Code Type}. +@xref{Closure Type}. @item autoload object @cindex autoload object @@ -227,6 +227,16 @@ Compilation}), or natively-compiled (@pxref{Native Compilation}), or a function loaded from a dynamic module (@pxref{Dynamic Modules}). @end defun +@defun interpreted-function-p object +This function returns @code{t} if @var{object} is an interpreted function. +@end defun + +@defun closurep object +This function returns @code{t} if @var{object} is a closure, which is +a particular kind of function object. Currently closures are used +for all byte-code functions and all interpreted functions. +@end defun + @defun subr-arity subr This works like @code{func-arity}, but only for built-in functions and without symbol indirection. It signals an error for non-built-in @@ -1136,8 +1146,7 @@ Functions}). @xref{describe-symbols example}, for a realistic example of this. When defining a lambda expression that is to be used as an anonymous -function, you can in principle use any method to construct the list. -But typically you should use the @code{lambda} macro, or the +function, you should use the @code{lambda} macro, or the @code{function} special form, or the @code{#'} read syntax: @defmac lambda args [doc] [interactive] body@dots{} @@ -1145,17 +1154,18 @@ This macro returns an anonymous function with argument list @var{args}, documentation string @var{doc} (if any), interactive spec @var{interactive} (if any), and body forms given by @var{body}. -Under dynamic binding, this macro effectively makes @code{lambda} -forms self-quoting: evaluating a form whose @sc{car} is @code{lambda} -yields the form itself: +For example, this macro makes @code{lambda} forms almost self-quoting: +evaluating a form whose @sc{car} is @code{lambda} yields a value that is +almost like the form itself: @example (lambda (x) (* x x)) - @result{} (lambda (x) (* x x)) + @result{} #f(lambda (x) :dynbind (* x x)) @end example -Note that when evaluating under lexical binding the result is a -closure object (@pxref{Closures}). +When evaluating under lexical binding the result is a similar +closure object, where the @code{:dynbind} marker is replaced by the +captured variables (@pxref{Closures}). The @code{lambda} form has one other effect: it tells the Emacs evaluator and byte-compiler that its argument is a function, by using @@ -1164,8 +1174,8 @@ evaluator and byte-compiler that its argument is a function, by using @defspec function function-object @cindex function quoting -This special form returns @var{function-object} without evaluating it. -In this, it is similar to @code{quote} (@pxref{Quoting}). But unlike +This special form returns the function value of the @var{function-object}. +In many ways, it is similar to @code{quote} (@pxref{Quoting}). But unlike @code{quote}, it also serves as a note to the Emacs evaluator and byte-compiler that @var{function-object} is intended to be used as a function. Assuming @var{function-object} is a valid lambda @@ -1495,7 +1505,7 @@ distinguish between a function cell that is void and one set to @group (defun bar (n) (+ n 2)) (symbol-function 'bar) - @result{} (lambda (n) (+ n 2)) + @result{} #f(lambda (n) [t] (+ n 2)) @end group @group (fset 'baz 'bar) @@ -1608,7 +1618,7 @@ argument list and body forms as the remaining elements: @example ;; @r{lexical binding is enabled.} (lambda (x) (* x x)) - @result{} (closure (t) (x) (* x x)) + @result{} #f(lambda (x) [t] (* x x)) @end example @noindent @@ -2699,6 +2709,57 @@ native code emitted for the function. In particular, if @var{n} is @minus{}1, native compilation of the function will emit bytecode instead of native code for the function. +@item (type @var{type}) +Declare @var{type} to be the type of this function. This is used for +documentation by @code{describe-function}. Also it can be used by the +native compiler (@pxref{Native Compilation}) for improving code +generation and for deriving more precisely the type of other functions +without type declaration. + +@var{type} is a type specifier in the form @w{@code{(function +(ARG-1-TYPE ... ARG-N-TYPE) RETURN-TYPE)}}. Argument types can be +interleaved with symbols @code{&optional} and @code{&rest} to match the +function's arguments (@pxref{Argument List}). + +Here's an example of using @code{type} inside @code{declare} to declare +a function @code{positive-p} that takes an argument of type @var{number} +and return a @var{boolean}: + +@lisp +@group +(defun positive-p (x) + (declare (type (function (number) boolean))) + (when (> x 0) + t)) +@end group +@end lisp + +Similarly this declares a function @code{cons-or-number} that: expects a +first argument being a @var{cons} or a @var{number}, a second optional +argument of type @var{string} and return one of the symbols +@code{is-cons} or @code{is-number}: + +@lisp +@group +(defun cons-or-number (x &optional err-msg) + (declare (type (function ((or cons number) &optional string) + (member is-cons is-number)))) + (if (consp x) + 'is-cons + (if (numberp x) + 'is-number + (error (or err-msg "Unexpected input"))))) +@end group +@end lisp + +For description of additional types, see @ref{Lisp Data Types}). + +Declaring a function with an incorrect type produces undefined behavior +and could lead to unexpected results or might even crash Emacs when code +is native-compiled and loaded. Note also that when redefining (or +advising) a type declared function the replacement should respect the +original signature to avoid undefined behavior. + @item no-font-lock-keyword This is valid for macros only. Macros with this declaration are highlighted by font-lock (@pxref{Font Lock Mode}) as normal functions, diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 1521b3815f4..32aa98d31cb 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -480,7 +480,7 @@ following values are available: This means all the commands in the keymap are repeatable, and is the most common usage. -@item (:enter (commands ...) :exit (commands ...)) +@item (:enter (commands ...) :exit (commands ...) :hints ((command . "hint") ...)) This specifies that the commands in the @code{:enter} list enter @code{repeat-mode}, and the commands in the @code{:exit} list exit repeat mode. @@ -494,6 +494,10 @@ If the @code{:exit} list is empty then no commands in the map exit @code{repeat-mode}. Specifying one or more commands in this list is useful if the keymap being defined contains a command that should not have the @code{repeat-map} property. + +The @code{:hints} list can contain cons pairs where the @sc{car} is +a command and the @sc{cdr} is a string that is displayed alongside of +the repeatable key in the echo area. @end table In order to make e.g.@: @kbd{u} repeat the @code{undo} command, the diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 1409e51c0d4..dce9115c61b 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -143,9 +143,9 @@ This function is the opposite of @code{listp}: it returns @code{t} if @defun null object This function returns @code{t} if @var{object} is @code{nil}, and returns @code{nil} otherwise. This function is identical to @code{not}, -but as a matter of clarity we use @code{null} when @var{object} is -considered a list and @code{not} when it is considered a truth value -(see @code{not} in @ref{Combining Conditions}). +but as a matter of clarity we use @code{not} when @var{object} is +considered a truth value (see @code{not} in @ref{Combining +Conditions}) and @code{null} otherwise. @example @group @@ -317,6 +317,7 @@ For historical reasons, it takes its arguments in the opposite order. @xref{Sequence Functions}. @end defun +@findex drop @defun nthcdr n list This function returns the @var{n}th @sc{cdr} of @var{list}. In other words, it skips past the first @var{n} links of @var{list} and returns @@ -327,6 +328,8 @@ If @var{n} is zero, @code{nthcdr} returns all of @var{list}. If the length of @var{list} is @var{n} or less, @code{nthcdr} returns @code{nil}. +An alias for @code{nthcdr} is @code{drop}. + @example @group (nthcdr 1 '(1 2 3 4)) @@ -350,6 +353,9 @@ it returns the part of @var{list} that @code{nthcdr} skips. @code{take} returns @var{list} if shorter than @var{n} elements; it returns @code{nil} if @var{n} is zero or negative. +In general, @code{(append (take @var{n} @var{list}) (drop @var{n} @var{list}))} +will return a list equal to @var{list}. + @example @group (take 3 '(a b c d)) @@ -1249,7 +1255,7 @@ this is not guaranteed to happen): @group (symbol-function 'add-foo) - @result{} (lambda (x) (nconc '(foo) x)) + @result{} #f(lambda (x) [t] (nconc '(foo) x)) @end group @group @@ -1267,7 +1273,7 @@ this is not guaranteed to happen): @group (symbol-function 'add-foo) - @result{} (lambda (x) (nconc '(foo 1 2 3 4) x)) + @result{} #f(lambda (x) [t] (nconc '(foo 1 2 3 4) x)) @end group @end smallexample @end defun diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index b034fecd77b..ffede9e86f5 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1109,7 +1109,10 @@ Versions before 24 did not have @code{change-major-mode-after-body-hook}. When user-implemented major modes do not use @code{run-mode-hooks} and have not been updated to use these newer features, they won't entirely follow these conventions: they may run the parent's mode hook too early, -or fail to run @code{after-change-major-mode-hook}. If you encounter +or fail to run @code{after-change-major-mode-hook}. This will +have undesirable effects such as preventing minor modes defined +with @code{define-globalized-minor-mode} from being enabled in +buffers using these major modes. If you encounter such a major mode, please correct it to follow these conventions. When you define a major mode using @code{define-derived-mode}, it @@ -1985,10 +1988,10 @@ turn on the minor mode in a buffer, it uses the function function so it could determine whether to enable the minor mode or not when it is not a priori clear that it should always be enabled.) -Globally enabling the mode also affects buffers subsequently created -by visiting files, and buffers that use a major mode other than -Fundamental mode; but it does not detect the creation of a new buffer -in Fundamental mode. +Globally enabling the mode affects only those buffers subsequently +created that use a major mode which follows the convention to run +@code{run-mode-hooks}. The minor mode will not be enabled in those +major modes which fail to follow this convention. This macro defines the customization option @var{global-mode} (@pxref{Customization}), which can be toggled via the Customize diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index aa1e073042f..ec6ab8204d6 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -244,7 +244,7 @@ latter are unique to Emacs Lisp. * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Closure Type:: A function written in Lisp. * Record Type:: Compound objects with programmer-defined types. * Type Descriptors:: Objects holding information about types. * Autoload Type:: A type used for automatically loading seldom-used @@ -1458,18 +1458,24 @@ with the name of the subroutine. @end group @end example -@node Byte-Code Type -@subsection Byte-Code Function Type +@node Closure Type +@subsection Closure Function Type -@dfn{Byte-code function objects} are produced by byte-compiling Lisp -code (@pxref{Byte Compilation}). Internally, a byte-code function -object is much like a vector; however, the evaluator handles this data -type specially when it appears in a function call. @xref{Byte-Code -Objects}. +@dfn{Closures} are function objects produced when turning a function +definition into a function value. Closures are used both for +byte-compiled Lisp functions as well as for interpreted Lisp functions. +Closures can be produced by byte-compiling Lisp code (@pxref{Byte +Compilation}) or simply by evaluating a lambda expression without +compiling it, resulting in an interpreted function. Internally, +a closure is much like a vector; however, the evaluator +handles this data type specially when it appears in a function call. +@xref{Closure Objects}. The printed representation and read syntax for a byte-code function object is like that for a vector, with an additional @samp{#} before the -opening @samp{[}. +opening @samp{[}. When printed for human consumption, it is printed as +a special kind of list with an additional @samp{#f} before the opening +@samp{(}. @node Record Type @subsection Record Type @@ -2030,7 +2036,7 @@ with references to further information. @xref{Array Functions, arrayp}. @item bignump -@xref{Predicates on Numbers, floatp}. +@xref{Predicates on Numbers, bignump}. @item bool-vector-p @xref{Bool-Vectors, bool-vector-p}. @@ -2042,10 +2048,7 @@ with references to further information. @xref{Buffer Basics, bufferp}. @item byte-code-function-p -@xref{Byte-Code Type, byte-code-function-p}. - -@item compiled-function-p -@xref{Byte-Code Type, compiled-function-p}. +@xref{Closure Type, byte-code-function-p}. @item case-table-p @xref{Case Tables, case-table-p}. @@ -2056,9 +2059,15 @@ with references to further information. @item char-table-p @xref{Char-Tables, char-table-p}. +@item closurep +@xref{What Is a Function, closurep}. + @item commandp @xref{Interactive Call, commandp}. +@item compiled-function-p +@xref{Closure Type, compiled-function-p}. + @item condition-variable-p @xref{Condition Variables, condition-variable-p}. @@ -2069,7 +2078,7 @@ with references to further information. @xref{Variable Definitions, custom-variable-p}. @item fixnump -@xref{Predicates on Numbers, floatp}. +@xref{Predicates on Numbers, fixnump}. @item floatp @xref{Predicates on Numbers, floatp}. @@ -2098,6 +2107,9 @@ with references to further information. @item integerp @xref{Predicates on Numbers, integerp}. +@item interpreted-function-p +@xref{What Is a Function, interpreted-function-p}. + @item keymapp @xref{Creating Keymaps, keymapp}. diff --git a/doc/lispref/parsing.texi b/doc/lispref/parsing.texi index 3d2192ace64..f79502f3bab 100644 --- a/doc/lispref/parsing.texi +++ b/doc/lispref/parsing.texi @@ -44,6 +44,7 @@ source files that mix multiple programming languages. * Retrieving Nodes:: Retrieving nodes from a syntax tree. * Accessing Node Information:: Accessing node information. * Pattern Matching:: Pattern matching with query patterns. +* User-defined Things:: User-defined ``Things'' and Navigation. * Multiple Languages:: Parse text written in multiple languages. * Tree-sitter Major Modes:: Develop major modes using tree-sitter. * Tree-sitter C API:: Compare the C API and the ELisp API. @@ -538,6 +539,26 @@ symbol, rather than a lambda function. This function returns the list of @var{parser}'s notifier functions. @end defun +Sometimes a Lisp program might need to synchronously get the changed +ranges of the last reparse. The function +@code{treesit-parser-changed-ranges} exists for this purpose. It +returns the ranges which were passed to the notifier functions. + +@defun treesit-parser-changed-ranges parser &optional quiet +This function returns the ranges that has been changed since last +reparse. It returns a list of cons cells of the form +@w{@code{(@var{start} . @var{end})}}, where @var{start} and @var{end} +mark the start and the end positions of a range. + +This function should almost always be called immediately after +reparsing. If it's called when there are new buffer edits that hasn't +been reparsed, Emacs signals the @code{treesit-unparsed-edits} error, +unless the optional argument @var{quiet} is non-nil. + +Calling this function multiple times consecutively doesn't change its +return value; it always returns the ranges affected by the last reparse. +@end defun + @node Retrieving Nodes @section Retrieving Nodes @cindex retrieve node, tree-sitter @@ -743,12 +764,17 @@ is non-@code{nil}, it looks for the smallest named child. @heading Searching for node @defun treesit-search-subtree node predicate &optional backward all depth -This function traverses the subtree of @var{node} (including -@var{node} itself), looking for a node for which @var{predicate} -returns non-@code{nil}. @var{predicate} is a regexp that is matched -against each node's type, or a predicate function that takes a node -and returns non-@code{nil} if the node matches. The function returns -the first node that matches, or @code{nil} if none does. +This function traverses the subtree of @var{node} (including @var{node} +itself), looking for a node for which @var{predicate} returns +non-@code{nil}. @var{predicate} is a regexp that is matched against +each node's type, or a predicate function that takes a node and returns +non-@code{nil} if the node matches. @var{predicate} can also be a thing +symbol or thing definition (@pxref{User-defined Things}). Using an +undefined thing doesn't raise an error, the function simply returns +@code{nil}. + +This function returns the first node that matches, or @code{nil} if node +matches @var{predicate}. By default, this function only traverses named nodes, but if @var{all} is non-@code{nil}, it traverses all the nodes. If @var{backward} is @@ -762,9 +788,13 @@ defaults to 1000. @defun treesit-search-forward start predicate &optional backward all Like @code{treesit-search-subtree}, this function also traverses the parse tree and matches each node with @var{predicate} (except for -@var{start}), where @var{predicate} can be a regexp or a function. -For a tree like the one below where @var{start} is marked @samp{S}, -this function traverses as numbered from 1 to 12: +@var{start}), where @var{predicate} can be a regexp or a predicate +function. @var{predicate} can also be a thing symbol or thing +definition (@pxref{User-defined Things}). Using an undefined thing +doesn't raise an error, the function simply returns @code{nil}. + +For a tree like the one below where @var{start} is marked @samp{S}, this +function traverses as numbered from 1 to 12: @example @group @@ -818,9 +848,11 @@ This function creates a sparse tree from @var{root}'s subtree. It takes the subtree under @var{root}, and combs it so only the nodes that match @var{predicate} are left. Like previous functions, the -@var{predicate} can be a regexp string that matches against each -node's type, or a function that takes a node and returns -non-@code{nil} if it matches. +@var{predicate} can be a regexp string that matches against each node's +type, or a function that takes a node and returns non-@code{nil} if it +matches. @var{predicate} can also be a thing symbol or thing definition +(@pxref{User-defined Things}). Using an undefined thing doesn't raise +an error, the function simply returns @code{nil}. For example, given the subtree on the left that consists of both numbers and letters, if @var{predicate} is ``letter only'', the @@ -1508,6 +1540,154 @@ For more details, read the tree-sitter project's documentation about pattern-matching, which can be found at @uref{https://tree-sitter.github.io/tree-sitter/using-parsers#pattern-matching-with-queries}. +@node User-defined Things +@section User-defined ``Things'' and Navigation +@cindex user-defined things, with tree-sitter parsing + +It's often useful to be able to identify and find certain @dfn{things} in +a buffer, like function and class definitions, statements, code blocks, +strings, comments, etc. Emacs allows users to define what kind of +tree-sitter node corresponds to a ``thing''. This enables handy +features like jumping to the next function, marking the code block at +point, or transposing two function arguments. + +The ``things'' feature in Emacs is independent of the pattern matching +feature of tree-sitter, and comparatively less powerful, but more +suitable for navigation and traversing the parse tree. + +You can define things with @var{treesit-thing-settings}. + +@defvar treesit-thing-settings +This is an alist of thing definitions for each language. The key of +each entry is a language symbol, and the value is a list of thing +definitions of the form @w{@code{(@var{thing} @var{pred})}}, where +@var{thing} is a symbol representing the thing, like @code{defun}, +@code{sexp}, or @code{sentence}; and @var{pred} specifies what kind of +tree-sitter node is this @var{thing}. + +@var{pred} can be a regexp string that matches the type of the node; it +can be a function that takes a node as the argument and returns a +boolean that indicates whether the node qualifies as the thing; or it can +be a cons @w{@code{(@var{regexp} . @var{fn})}}, which is a combination +of a regular expression @var{regexp} and a function @var{fn}---the node +has to match both the @var{regexp} and to satisfy @var{fn} to qualify as +the thing. + +@var{pred} can also be recursively defined. It can be @w{@code{(or +@var{pred}@dots{})}}, meaning that satisfying any one of the @var{pred}s +qualifies the node as the thing. It can be @w{@code{(not @var{pred})}}, +meaning that not satisfying @var{pred} qualifies the node. + +Finally, @var{pred} can refer to other @var{thing}s defined in this +list. For example, @w{@code{(or sexp sentence)}} defines something +that's either a @code{sexp} thing or a @code{sentence} thing, as defined +by some other rule in the alist. + +Here's an example @var{treesit-thing-settings} for C and C++: + +@example +@group +((c + (defun "function_definition") + (sexp (not "[](),[@{@}]")) + (comment "comment") + (string "raw_string_literal") + (text (or comment string))) + (cpp + (defun ("function_definition" . cpp-ts-mode-defun-valid-p)) + (defclass "class_specifier") + (comment "comment"))) +@end group +@end example + +@noindent +Note that this example is modified for didactical purposes, and isn't +exactly how C and C@t{++} modes define things. +@end defvar + +The rest of this section lists a few functions that take advantage of +the thing definitions. Besides the functions below, some other +functions listed elsewhere also utilize the thing feature, e.g., +tree-traversing functions like @code{treesit-search-forward}, +@code{treesit-induce-sparse-tree}, etc. @xref{Retrieving Nodes}. + +@defun treesit-thing-prev position thing +This function returns the first node before @var{position} that is the +specified @var{thing}. If no such node exists, it returns @code{nil}. +It's guaranteed that, if a node is returned, the node's end position is +less or equal to @var{position}. In other words, this function never +returns a node that encloses @var{position}. + +@var{thing} can be either a thing symbol like @code{defun}, or simply a +thing definition like @code{"function_definition"}. +@end defun + +@defun treesit-thing-next position thing +This function is similar to @code{treesit-thing-prev}, only it returns +the first node @emph{after} @var{position} that's the @var{thing}. It +also guarantees that if a node is returned, the node's start position is +greater or equal to @var{position}. +@end defun + +@defun treesit-navigate-thing position arg side thing &optional tactic +This function builds upon @code{treesit-thing-prev} and +@code{treesit-thing-next} and provides functionality that a navigation +command would find useful. It returns the position after moving across +@var{arg} instances of @var{thing} from @var{position}. If +there aren't enough things to navigate across, it returns nil. The +function doesn't move point. + +A positive @var{arg} means moving forward that many instances of +@var{thing}; negative @var{arg} means moving backward. If @var{side} is +@code{beg}, this function stops at the beginning of @var{thing}; if +@code{end}, stop at the end of @var{thing}. + +Like in @code{treesit-thing-prev}, @var{thing} can be a thing symbol +defined in @var{treesit-thing-settings}, or a thing definition. + +@var{tactic} determines how this function moves between things. It can +be @code{nested}, @code{top-level}, @code{restricted}, or @code{nil}. +@code{nested} or @code{nil} means normal nested navigation: first try to +move across siblings; if there aren't any siblings left in the current +level, move to the parent, then its siblings, and so on. +@code{top-level} means only navigate across top-level things and ignore +nested things. @code{restricted} means movement is restricted within +the thing that encloses @var{position}, if there is such a thing. This +tactic is useful for commands that want to stop at the current nesting +level and not move up. +@end defun + +@defun treesit-thing-at position thing &optional strict +This function returns the smallest node that's the @var{thing} and +encloses @var{position}; if there's no such node, it returns @code{nil}. + +The returned node must enclose @var{position}, i.e., its start position is +less or equal to @var{position}, and it's end position is greater or equal to +@var{position}. + +If @var{strict} is non-@code{nil}, this function uses strict comparison, +i.e., start position must be strictly greater than @var{position}, and end +position must be strictly less than @var{position}. + +@var{thing} can be either a thing symbol defined in +@var{treesit-thing-settings}, or a thing definition. +@end defun + +@findex treesit-beginning-of-thing +@findex treesit-end-of-thing +@findex treesit-thing-at-point +There are also some convenient wrapper functions. +@code{treesit-beginning-of-thing} moves point to the beginning of a +thing, @code{treesit-end-of-thing} moves to the end of a thing, and +@code{treesit-thing-at-point} returns the thing at point. + +There are also defun commands that specifically use the @code{defun} +definition (as a fallback of @var{treesit-defun-type-regexp}), like +@code{treesit-beginning-of-defun}, @code{treesit-end-of-defun}, and +@code{treesit-defun-at-point}. In addition, these functions use +@var{treesit-defun-tactic} as the navigation tactic. They are described +in more detail in other sections (@pxref{Tree-sitter Major Modes}). + @node Multiple Languages @section Parsing Text in Multiple Languages @cindex multiple languages, parsing with tree-sitter @@ -1901,6 +2081,13 @@ non-@code{nil}, it sets up Imenu. @item If @code{treesit-outline-predicate} (@pxref{Outline Minor Mode}) is non-@code{nil}, it sets up Outline minor mode. + +@item +If @code{sexp} and/or @code{sentence} are defined in +@code{treesit-thing-settings} (@pxref{User-defined Things}), it enables +navigation commands that move, respectively, by sexps and sentences by +defining variables such as @code{forward-sexp-function} and +@code{forward-sentence-function}. @end itemize @c TODO: Add treesit-thing-settings stuff once we finalize it. diff --git a/doc/lispref/peg.texi b/doc/lispref/peg.texi new file mode 100644 index 00000000000..b85d0de048d --- /dev/null +++ b/doc/lispref/peg.texi @@ -0,0 +1,416 @@ +@c -*-texinfo-*- +@c This is part of the GNU Emacs Lisp Reference Manual. +@c Copyright (C) 1990--1995, 1998--1999, 2001--2024 Free Software +@c Foundation, Inc. +@c See the file elisp.texi for copying conditions. +@node Parsing Expression Grammars +@chapter Parsing Expression Grammars +@cindex text parsing +@cindex parsing expression grammar +@cindex PEG + + Emacs Lisp provides several tools for parsing and matching text, +from regular expressions (@pxref{Regular Expressions}) to full +left-to-right (a.k.a.@: @acronym{LL}) grammar parsers (@pxref{Top,, +Bovine parser development,bovine}). @dfn{Parsing Expression Grammars} +(@acronym{PEG}) are another approach to text parsing that offer more +structure and composibility than regular expressions, but less +complexity than context-free grammars. + +A Parsing Expression Grammar (@acronym{PEG}) describes a formal language +in terms of a set of rules for recognizing strings in the language. In +Emacs, a @acronym{PEG} parser is defined as a list of named rules, each +of which matches text patterns and/or contains references to other +rules. Parsing is initiated with the function @code{peg-run} or the +macro @code{peg-parse} (see below), and parses text after point in the +current buffer, using a given set of rules. + +@cindex parsing expression +@cindex root, of parsing expression grammar +@cindex entry-point, of parsing expression grammar +Each rule in a @acronym{PEG} is referred to as a @dfn{parsing +expression} (@acronym{PEX}), and can be specified a a literal string, a +regexp-like character range or set, a peg-specific construct resembling +an Emacs Lisp function call, a reference to another rule, or a +combination of any of these. A grammar is expressed as a tree of rules +in which one rule is typically treated as a ``root'' or ``entry-point'' +rule. For instance: + +@example +@group +((number sign digit (* digit)) + (sign (or "+" "-" "")) + (digit [0-9])) +@end group +@end example + +Once defined, grammars can be used to parse text after point in the +current buffer, in a number of ways. The @code{peg-parse} macro is the +simplest: + +@defmac peg-parse &rest pexs +Match @var{pexs} at point. +@end defmac + +@example +@group +(peg-parse + (number sign digit (* digit)) + (sign (or "+" "-" "")) + (digit [0-9])) +@end group +@end example + +While this macro is simple it is also inflexible, as the rules must be +written directly into the source code. More flexibility can be gained +by using a combination of other functions and macros. + +@defmac with-peg-rules rules &rest body +Execute @var{body} with @var{rules}, a list of @acronym{PEX}s, in +effect. Within @var{BODY}, parsing is initiated with a call to +@code{peg-run}. +@end defmac + +@defun peg-run peg-matcher &optional failure-function success-function +This function accepts a single @var{peg-matcher}, which is the result of +calling @code{peg} (see below) on a named rule, usually the entry-point +of a larger grammar. + +At the end of parsing, one of @var{failure-function} or +@var{success-function} is called, depending on whether the parsing +succeeded or not. If @var{success-function} is provided, it should be a +function that receives as its only argument an anonymous function that +runs all the actions collected on the stack during parsing. By default +this anonymous function is simply executed. If parsing fails, a +function provided as @var{failure-function} will be called with a list +of @acronym{PEG} expressions that failed during parsing. By default +this list is discarded. +@end defun + +The @var{peg-matcher} passed to @code{peg-run} is produced by a call to +@code{peg}: + +@defmac peg &rest pexs +Convert @var{pexs} into a single peg-matcher suitable for passing to +@code{peg-run}. +@end defmac + +The @code{peg-parse} example above expands to a set of calls to these +functions, and could be written in full as: + +@example +@group +(with-peg-rules + ((number sign digit (* digit)) + (sign (or "+" "-" "")) + (digit [0-9])) + (peg-run (peg number))) +@end group +@end example + +This approach allows more explicit control over the ``entry-point'' of +parsing, and allows the combination of rules from different sources. + +Individual rules can also be defined using a more @code{defun}-like +syntax, using the macro @code{define-peg-rule}: + +@defmac define-peg-rule name args &rest pexs +Define @var{name} as a PEG rule that accepts @var{args} and matches +@var{pexs} at point. +@end defmac + +For instance: + +@example +@group +(define-peg-rule digit () + [0-9]) +@end group +@end example + +Arguments can be supplied to rules by the @code{funcall} PEG rule +(@pxref{PEX Definitions}). + +Another possibility is to define a named set of rules with +@code{define-peg-ruleset}: + +@defmac define-peg-ruleset name &rest rules +Define @var{name} as an identifier for @var{rules}. +@end defmac + +@example +@group +(define-peg-ruleset number-grammar + '((number sign digit (* digit)) + digit ;; A reference to the definition above. + (sign (or "+" "-" "")))) +@end group +@end example + +Rules and rulesets defined this way can be referred to by name in +later calls to @code{peg-run} or @code{with-peg-rules}: + +@example +@group +(with-peg-rules number-grammar + (peg-run (peg number))) +@end group +@end example + +By default, calls to @code{peg-run} or @code{peg-parse} produce no +output: parsing simply moves point. In order to return or otherwise +act upon parsed strings, rules can include @dfn{actions}, see +@ref{Parsing Actions}. + +@menu +* PEX Definitions:: The syntax of PEX rules. +* Parsing Actions:: Running actions upon successful parsing. +* Writing PEG Rules:: Tips for writing parsing rules. +@end menu + +@node PEX Definitions +@section PEX Definitions + +Parsing expressions can be defined using the following syntax: + +@table @code +@item (and @var{e1} @var{e2}@dots{}) +A sequence of @acronym{PEX}s that must all be matched. The @code{and} +form is optional and implicit. + +@item (or @var{e1} @var{e2}@dots{}) +Prioritized choices, meaning that, as in Elisp, the choices are tried +in order, and the first successful match is used. Note that this is +distinct from context-free grammars, in which selection between +multiple matches is indeterminate. + +@item (any) +Matches any single character, as the regexp ``.''. + +@item @var{string} +A literal string. + +@item (char @var{c}) +A single character @var{c}, as an Elisp character literal. + +@item (* @var{e}) +Zero or more instances of expression @var{e}, as the regexp @samp{*}. +Matching is always ``greedy''. + +@item (+ @var{e}) +One or more instances of expression @var{e}, as the regexp @samp{+}. +Matching is always ``greedy''. + +@item (opt @var{e}) +Zero or one instance of expression @var{e}, as the regexp @samp{?}. + +@item @var{symbol} +A symbol representing a previously-defined PEG rule. + +@item (range @var{ch1} @var{ch2}) +The character range between @var{ch1} and @var{ch2}, as the regexp +@samp{[@var{ch1}-@var{ch2}]}. + +@item [@var{ch1}-@var{ch2} "+*" ?x] +A character set, which can include ranges, character literals, or +strings of characters. + +@item [ascii cntrl] +A list of named character classes. + +@item (syntax-class @var{name}) +A single syntax class. + +@item (funcall @var{e} @var{args}@dots{}) +Call @acronym{PEX} @var{e} (previously defined with +@code{define-peg-rule}) with arguments @var{args}. + +@item (null) +The empty string. +@end table + +The following expressions are used as anchors or tests -- they do not +move point, but return a boolean value which can be used to constrain +matches as a way of controlling the parsing process (@pxref{Writing +PEG Rules}). + +@table @code +@item (bob) +Beginning of buffer. + +@item (eob) +End of buffer. + +@item (bol) +Beginning of line. + +@item (eol) +End of line. + +@item (bow) +Beginning of word. + +@item (eow) +End of word. + +@item (bos) +Beginning of symbol. + +@item (eos) +End of symbol. + +@item (if @var{e}) +Returns non-@code{nil} if parsing @acronym{PEX} @var{e} from point +succeeds (point is not moved). + +@item (not @var{e}) +Returns non-@code{nil} if parsing @acronym{PEX} @var{e} from point fails +(point is not moved). + +@item (guard @var{exp}) +Treats the value of the Lisp expression @var{exp} as a boolean. +@end table + +@vindex peg-char-classes +Character-class matching can refer to the classes named in +@code{peg-char-classes}, equivalent to character classes in regular +expressions (@pxref{Top,, Character Classes,elisp}) + +@node Parsing Actions +@section Parsing Actions + +@cindex parsing actions +@cindex parsing stack +By default the process of parsing simply moves point in the current +buffer, ultimately returning @code{t} if the parsing succeeds, and +@code{nil} if it doesn't. It's also possible to define @dfn{parsing +actions} that can run arbitrary Elisp at certain points in the parsed +text. These actions can optionally affect something called the +@dfn{parsing stack}, which is a list of values returned by the parsing +process. These actions only run (and only return values) if the parsing +process ultimately succeeds; if it fails the action code is not run at +all. + +Actions can be added anywhere in the definition of a rule. They are +distinguished from parsing expressions by an initial backquote +(@samp{`}), followed by a parenthetical form that must contain a pair +of hyphens (@samp{--}) somewhere within it. Symbols to the left of +the hyphens are bound to values popped from the stack (they are +somewhat analogous to the argument list of a lambda form). Values +produced by code to the right of the hyphens are pushed onto the stack +(analogous to the return value of the lambda). For instance, the +previous grammar can be augmented with actions to return the parsed +number as an actual integer: + +@example +@group +(with-peg-rules ((number sign digit (* digit + `(a b -- (+ (* a 10) b))) + `(sign val -- (* sign val))) + (sign (or (and "+" `(-- 1)) + (and "-" `(-- -1)) + (and "" `(-- 1)))) + (digit [0-9] `(-- (- (char-before) ?0)))) + (peg-run (peg number))) +@end group +@end example + +There must be values on the stack before they can be popped and +returned -- if there aren't enough stack values to bind to an action's +left-hand terms, they will be bound to @code{nil}. An action with +only right-hand terms will push values to the stack; an action with +only left-hand terms will consume (and discard) values from the stack. +At the end of parsing, stack values are returned as a flat list. + +To return the string matched by a @acronym{PEX} (instead of simply +moving point over it), a grammar can use a rule like this: + +@example +@group +(one-word + `(-- (point)) + (+ [word]) + `(start -- (buffer-substring start (point)))) +@end group +@end example + +@noindent +The first action above pushes the initial value of point to the stack. +The intervening @acronym{PEX} moves point over the next word. The +second action pops the previous value from the stack (binding it to the +variable @code{start}), then uses that value to extract a substring from +the buffer and push it to the stack. This pattern is so common that +@acronym{PEG} provides a shorthand function that does exactly the above, +along with a few other shorthands for common scenarios: + +@table @code +@findex substring (a PEG shorthand) +@item (substring @var{e}) +Match @acronym{PEX} @var{e} and push the matched string onto the stack. + +@findex region (a PEG shorthand) +@item (region @var{e}) +Match @var{e} and push the start and end positions of the matched +region onto the stack. + +@findex replace (a PEG shorthand) +@item (replace @var{e} @var{replacement}) +Match @var{e} and replaced the matched region with the string +@var{replacement}. + +@findex list (a PEG shorthand) +@item (list @var{e}) +Match @var{e}, collect all values produced by @var{e} (and its +sub-expressions) into a list, and push that list onto the stack. Stack +values are typically returned as a flat list; this is a way of +``grouping'' values together. +@end table + +@node Writing PEG Rules +@section Writing PEG Rules +@cindex PEG rules, pitfalls +@cindex Parsing Expression Grammar, pitfalls in rules + +Something to be aware of when writing PEG rules is that they are +greedy. Rules which can consume a variable amount of text will always +consume the maximum amount possible, even if that causes a rule that +might otherwise have matched to fail later on -- there is no +backtracking. For instance, this rule will never succeed: + +@example +(forest (+ "tree" (* [blank])) "tree" (eol)) +@end example + +@noindent +The @acronym{PEX} @w{@code{(+ "tree" (* [blank]))}} will consume all +the repetitions of the word @samp{tree}, leaving none to match the final +@samp{tree}. + +In these situations, the desired result can be obtained by using +predicates and guards -- namely the @code{not}, @code{if} and +@code{guard} expressions -- to constrain behavior. For instance: + +@example +(forest (+ "tree" (* [blank])) (not (eol)) "tree" (eol)) +@end example + +@noindent +The @code{if} and @code{not} operators accept a parsing expression and +interpret it as a boolean, without moving point. The contents of a +@code{guard} operator are evaluated as regular Lisp (not a +@acronym{PEX}) and should return a boolean value. A @code{nil} value +causes the match to fail. + +Another potentially unexpected behavior is that parsing will move +point as far as possible, even if the parsing ultimately fails. This +rule: + +@example +(end-game "game" (eob)) +@end example + +@noindent +when run in a buffer containing the text ``game over'' after point, +will move point to just after ``game'' then halt parsing, returning +@code{nil}. Successful parsing will always return @code{t}, or the +contexts of the parsing stack. diff --git a/doc/lispref/positions.texi b/doc/lispref/positions.texi index 5e0143c7131..9193c1063d1 100644 --- a/doc/lispref/positions.texi +++ b/doc/lispref/positions.texi @@ -892,8 +892,8 @@ parser information to move across syntax constructs. Since what exactly is considered a sexp varies between languages, a major mode should set @code{treesit-thing-settings} to determine that. Then the mode can get navigation-by-sexp functionality for free, by using -@code{forward-sexp} and @code{backward-sexp}(@pxref{Moving by -Sentences,,, emacs, The extensible self-documenting text editor}). +@code{forward-sexp} and @code{backward-sexp}(@pxref{Expressions, +,, emacs, The extensible self-documenting text editor}). @node Skipping Characters @subsection Skipping Characters diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ea3fe738f69..c356c905dee 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -687,7 +687,7 @@ The arguments @var{args} are a list of keyword/argument pairs. Omitting a keyword is always equivalent to specifying it with value @code{nil}. Here are the meaningful keywords: -@table @asis +@table @code @item :name @var{name} Use the string @var{name} as the process name; if a process with this name already exists, then @var{name} is modified (by appending @@ -817,7 +817,7 @@ Omitting a keyword is always equivalent to specifying it with value Here are the meaningful keywords: -@table @asis +@table @code @item :name @var{name} Use the string @var{name} as the process name. As with @code{make-process}, it is modified if necessary to make it unique. @@ -2828,7 +2828,7 @@ equivalent to specifying it with value @code{nil}, except for are the meaningful keywords (those corresponding to network options are listed in the following section): -@table @asis +@table @code @item :name @var{name} Use the string @var{name} as the process name. It is modified if necessary to make it unique. @@ -3017,7 +3017,7 @@ modify these options later, using @code{set-network-process-option}. connections, so you will need to set the necessary options for each child connection as it is created. -@table @asis +@table @code @item :bindtodevice @var{device-name} If @var{device-name} is a non-empty string identifying a network interface name (see @code{network-interface-list}), only handle diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index c9e47624878..4c5525f10c5 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -1583,7 +1583,7 @@ nonempty vector that is not @code{eq} to any existing vector. The @code{vconcat} function also allows byte-code function objects as arguments. This is a special feature to make it easy to access the entire -contents of a byte-code function object. @xref{Byte-Code Objects}. +contents of a byte-code function object. @xref{Closure Objects}. For other concatenation functions, see @code{mapconcat} in @ref{Mapping Functions}, @code{concat} in @ref{Creating Strings}, and @code{append} diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 3d14a5ad8be..07fb730f0f1 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3663,6 +3663,16 @@ non-@code{nil} @code{help-echo-inhibit-substitution} property, then it is displayed as-is by @code{show-help-function}, without being passed through @code{substitute-command-keys}. +@item left-fringe-help +@itemx right-fringe-help +@cindex help-echo text on fringes +If any visible text of a screen line has the @code{left-fringe-help} or +@code{right-fringe-help} text property whose value is a string, then +that string will be displayed when the mouse pointer hovers over the +corresponding line's fringe through @code{show-help-function} +(@pxref{Help display}). This is useful when used together with fringe +cursors and bitmaps (@pxref{Fringes}). + @item keymap @cindex keymap of character @kindex keymap @r{(text property)} @@ -5752,10 +5762,10 @@ non-@code{nil}, indent the @acronym{HTML}/@acronym{XML} logically. @cindex JSON @cindex JavaScript Object Notation - When Emacs is compiled with @acronym{JSON} (@dfn{JavaScript Object -Notation}) support, it provides several functions to convert -between Lisp objects and JSON values. Any JSON value can be converted -to a Lisp object, but not vice versa. Specifically: + The Emacs @acronym{JSON} (@dfn{JavaScript Object Notation}) support +provides several functions to convert between Lisp objects and JSON +values. Any JSON value can be converted to a Lisp object, but not vice +versa. Specifically: @itemize @item @@ -5790,12 +5800,6 @@ represents @code{@{@}}, the empty JSON object; not @code{null}, @code{false}, or an empty array, all of which are different JSON values. -@defun json-available-p -This predicate returns non-@code{nil} if Emacs has been built with -@acronym{JSON} support, and the library is available on the current -system. -@end defun - If some Lisp object can't be represented in JSON, the serialization functions will signal an error of type @code{wrong-type-argument}. The parsing functions can also signal the following errors: @@ -5839,7 +5843,7 @@ keyword @code{false}. It defaults to the symbol @code{:false}. @defun json-insert object &rest args This function inserts the JSON representation of @var{object} into the current buffer before point. The argument @var{args} are interpreted -as in @code{json-parse-string}. +as in @code{json-serialize}. @end defun @defun json-parse-string string &rest args @@ -6381,3 +6385,155 @@ hooks during a series of changes (typically for performance reasons), use @code{combine-change-calls} or @code{combine-after-change-calls} instead. @end defvar + +@menu +* Tracking changes:: Keeping track of buffer modifications. +@end menu + +@node Tracking changes +@subsection Keeping track of buffer modifications +@cindex track-changes +@cindex change tracker + +Using @code{before-change-functions} and @code{after-change-functions} +can be difficult in practice because of a number of pitfalls, such as +the fact that the two calls are not always properly paired, or some +calls may be missing, either because some Emacs primitives failed to +properly pair them or because of incorrect use of +@code{inhibit-modification-hooks}. Furthermore, +many restrictions apply to those hook functions, such as the fact that +they basically should never modify the current buffer, nor use an +operation that may block, and they proceed quickly because +some commands may call these hooks a large number of times. + +The Track-Changes library fundamentally provides an alternative API, +built on top of those hooks. Compared to @code{after-change-functions}, +the first important difference is that, instead of providing the bounds +of the change and the previous length, it provides the bounds of the +change and the actual previous content of that region. The need to +extract information from the original contents of the buffer is one of +the main reasons why some packages need to use both +@code{before-change-functions} and @code{after-change-functions} and +then try to match them up. + +The second difference is that it decouples the notification of a change +from the act of processing it, and it automatically combines into +a single change operation all the changes that occur between the first +change and the actual processing. This makes it natural and easy to +process the changes at a larger granularity, such as once per command, +and eliminates most of the restrictions that apply to the usual change +hook functions, making it possible to use blocking operations or to +modify the buffer. + +To start tracking changes, you have to call +@code{track-changes-register}, passing it a @var{signal} function as +argument. This returns a tracker @var{id} which is used to identify +your change tracker to the other functions of the library. +When the buffer is modified, the library calls the @var{signal} +function to inform you of that change and immediately starts +accumulating subsequent changes into a single combined change. +The @var{signal} function serves only to warn that a modification +occurred but does not receive a description of the change. Also the +library will not call it again until after you retrieved the change. + +To retrieve changes, you need to call @code{track-changes-fetch}, which +provides you with the bounds of the changes accumulated since the +last call, as well as the previous content of that region. It also +``re-arms'' the @var{signal} function so that the library will call it +again after the next buffer modification. + +@defun track-changes-register signal &key nobefore disjoint immediate +This function creates a new @dfn{change tracker}. Change trackers are kept +abstract, so we refer to them as mere identities, and the function thus +returns the tracker's @var{id}. + +@var{signal} is a function that the library will call to notify of +a change. It will sometimes call it with a single argument and +sometimes with two. Upon the first change to the buffer since this +tracker last called @code{track-changes-fetch}, the library calls this +@var{signal} function with a single argument holding the @var{id} of +the tracker. + +By default, the call to the @var{signal} function does not happen +immediately, but is instead postponed with a 0 seconds timer +(@pxref{Timers}). This is usually desired to make sure the @var{signal} +function is not called too frequently and runs in a permissive context, +freeing the client from performance concerns or worries about which +operations might be problematic. If a client wants to have more +control, they can provide a non-@code{nil} value as the @var{immediate} +argument in which case the library calls the @var{signal} function +directly from @code{after-change-functions}. Beware that it means that +the @var{signal} function has to be careful not to modify the buffer or +use operations that may block. + +If you're not interested in the actual previous content of the buffer, +but are using this library only for its ability to combine many small +changes into a larger one and to delay the processing to a more +convenient time, you can specify a non-@code{nil} value for the +@var{nobefore} argument. In that case, @code{track-change-fetch} +provides you only with the length of the previous content, just like +@code{after-change-functions}. It also allows the library to save +some work. + +While you may like to accumulate many small changes into larger ones, +you may not want to do that if the changes are too far apart. If you +specify a non-@code{nil} value for the @var{disjoint} argument, the library +will let you know when a change is about to occur ``far'' from the +currently pending ones by calling the @var{signal} function right away, +passing it two arguments this time: the @var{id} of the tracker, and the +number of characters that separates the upcoming change from the +already pending changes. This in itself does not prevent combining this +new change with the previous ones, so if you think the upcoming change +is indeed too far, you need to call @code{track-change-fetch} +right away. +Beware that when the @var{signal} function is called because of +a disjoint change, this happens directly from +@code{before-change-functions}, so the usual restrictions apply about +modifying the buffer or using operations that may block. +@end defun + +@defun track-changes-fetch id func +This is the function that lets you find out what has changed in the +buffer. By providing the tracker @var{id} you let the library figure +out which changes have already been seen by your tracker. Instead of +returning a description of the changes, @code{track-changes-fetch} calls +the @var{func} function with that description in the form of +3 arguments: @var{beg}, @var{end}, and @var{before}, where +@code{@var{beg}..@var{end}} delimit the region that was modified and +@var{before} describes the previous content of that region. +Usually @var{before} is a string containing the previous text of the +modified region, but if you specified a non-@code{nil} @var{nobefore} argument +to @code{track-changes-register}, then it is replaced by the number of +characters of that previous text. + +In case no changes occurred since the last call, +@code{track-changes-fetch} simply does not call @var{func} and returns +@code{nil}. If changes did occur, it calls @var{func} and returns the value +returned by @var{func}. But note that @var{func} is called just once +regardless of how many changes occurred: those are summarized into +a single @var{beg}/@var{end}/@var{before} triplet. + +In some cases, the library is not properly notified of all changes, +for example because of a bug in the low-level C code or because of an +improper use of @code{inhibit-modification-hooks}. When it detects such +a problem, @var{func} receives a @code{@var{beg}..@var{end}} region +which covers the whole buffer and the @var{before} argument is the +symbol @code{error} to indicate that the library was unable to determine +what was changed. + +Once @var{func} finishes, @code{track-changes-fetch} re-enables the +@var{signal} function so that it will be called the next time a change +occurs. This is the reason why it calls @var{func} instead of returning +a description: it lets you process the change without worrying about the +risk that the @var{signal} function gets triggered in the middle of it, +because the @var{signal} is re-enabled only after @var{func} finishes. +@end defun + +@defun track-changes-unregister id +This function tells the library that the tracker @var{id} does not need +to know about buffer changes any more. Most clients will never want to +stop tracking changes, but for clients such as minor modes, it is +important to call this function when the minor mode is disabled, +otherwise the tracker will keep accumulating changes and consume more +and more resources. +@end defun diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi index 0db9a35ac6f..1e35b82e413 100644 --- a/doc/lispref/tips.texi +++ b/doc/lispref/tips.texi @@ -834,13 +834,15 @@ it substitutes whatever key is currently bound to @code{forward-char}. user has moved key bindings.) @xref{Keys in Documentation}. @item -In documentation strings for a major mode, you will want to refer to the -key bindings of that mode's local map, rather than global ones. +In documentation strings for a major mode, you will want to refer to +the key bindings of that mode's local map, rather than global ones. Therefore, use the construct @samp{\\<@dots{}>} once in the documentation string to specify which key map to use. Do this before -the first use of @samp{\\[@dots{}]}. The text inside the -@samp{\\<@dots{}>} should be the name of the variable containing the -local keymap for the major mode. +the first use of @samp{\\[@dots{}]}, and not in the middle of a +sentence (since if the map is not loaded, the reference to the map +will be replaced with a sentence saying the map is not currently +defined). The text inside the @samp{\\<@dots{}>} should be the name +of the variable containing the local keymap for the major mode. Each use of @samp{\\[@dots{}]} slows the display of the documentation string by a tiny amount. If you use a lot of them, these tiny diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 4d61d461deb..16b6b52e5f1 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -1079,7 +1079,7 @@ Here is an example: (let ((x 0)) ; @r{@code{x} is lexically bound.} (setq my-ticker (lambda () (setq x (1+ x))))) - @result{} (closure ((x . 0)) () + @result{} #f(lambda () [(x 0)] (setq x (1+ x))) (funcall my-ticker) diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index eef05d94fdb..104420235df 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -2638,6 +2638,29 @@ use @code{derived-mode} or @code{major-mode} as condition, @code{buffer-match-p} could fail to report a match if @code{display-buffer} is called before the major mode of the buffer is set. + +If the caller of @code{display-buffer} passes a category as a symbol +in its @var{action} argument, then you can use the same category in +@code{display-buffer-alist} to match buffers with different names, +for example: + +@example +@group +(setopt + display-buffer-alist + (cons '((category . comint) (display-buffer-same-window)) + display-buffer-alist)) + +(display-buffer (get-buffer-create "*my-shell*") + '(nil (category . comint))) +@end group +@end example + +Regardless of the displayed buffer's name the caller defines a category +as a symbol @code{comint}. Then @code{display-buffer-alist} matches +this category for all buffers displayed with the same category. +This avoids the need to construct a complex regular expression +that matches a buffer name. @end defopt @defopt display-buffer-base-action @@ -3354,6 +3377,13 @@ If the value is @code{nil}, the buffer selected by such functions as @code{pop-to-buffer} is deselected, and the window that was selected before calling this function will remain selected regardless of which windows were selected afterwards within this command. + +@vindex category@r{, a buffer display action alist entry} +@item category +If the caller of @code{display-buffer} passes an alist entry +@code{(category . symbol)} in its @var{action} argument, then you can +match the displayed buffer by using the same category in the condition +part of @code{display-buffer-alist} entries. @end table By convention, the entries @code{window-height}, @code{window-width} @@ -6177,7 +6207,7 @@ The following option enables automatically selecting the window under the mouse pointer. This accomplishes a policy similar to that of window managers that give focus to a frame (and thus trigger its subsequent selection) whenever the mouse pointer enters its -window-system window (@pxref{Input Focus}). +window-system window (@pxref{Input Focus}, @pxref{Focus Events}). @defopt mouse-autoselect-window If this variable is non-@code{nil}, Emacs will try to automatically diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index ac2ac5a0f91..f7b7e277b58 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -31468,6 +31468,7 @@ newline so that mode annotations will appear on lines by themselves. @node Programming @chapter Programming +@cindex Programming Calc @noindent There are several ways to ``program'' the Emacs Calculator, depending on the nature of the problem you need to solve. @@ -31596,7 +31597,7 @@ following sections. @noindent @kindex X -@cindex Programming with keyboard macros +@cindex Programming Calc, with keyboard macros @cindex Keyboard macros The easiest way to ``program'' the Emacs Calculator is to use standard keyboard macros. Press @w{@kbd{C-x (}} to begin recording a macro. From @@ -31997,7 +31998,7 @@ The @kbd{m m} command saves the last invocation macro defined by @noindent @kindex Z F @pindex calc-user-define-formula -@cindex Programming with algebraic formulas +@cindex Programming Calc, with algebraic formulas Another way to create a new Calculator command uses algebraic formulas. The @kbd{Z F} (@code{calc-user-define-formula}) command stores the formula at the top of the stack as the definition for a key. This @@ -32106,6 +32107,7 @@ in symbolic form without ever activating the @code{deriv} function. Press @node Lisp Definitions @section Programming with Lisp +@section Programming Calc, with Lisp @noindent The Calculator can be programmed quite extensively in Lisp. All you do is write a normal Lisp function definition, but with @code{defmath} @@ -32851,6 +32853,7 @@ a large argument, a simpler program like the first one shown is fine. @node Calling Calc from Your Programs @subsection Calling Calc from Your Lisp Programs +@cindex Calling Calc from Lisp @noindent A later section (@pxref{Internals}) gives a full description of Calc's internal Lisp functions. It's not hard to call Calc from diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 65a29d955bc..a4a34ae07d6 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -1426,7 +1426,7 @@ the function bindings can be recursive. The scoping is lexical, but you can only capture functions in closures if @code{lexical-binding} is @code{t}. @xref{Closures,,,elisp,GNU Emacs Lisp Reference Manual}, and -@ref{Using Lexical Binding,,,elisp,GNU Emacs Lisp Reference Manual}. +@ref{Selecting Lisp Dialect,,,elisp,GNU Emacs Lisp Reference Manual}. Lexical scoping means that all references to the named functions must appear physically within the body of the diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 28ee64d6b89..e5d867acd40 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -1083,8 +1083,8 @@ elements of this array. Example: @defun dbus-string-to-byte-array string Sometimes, D-Bus methods require as input parameter an array of bytes, -instead of a string. If it is guaranteed, that @var{string} is a -UTF-8 string, this function performs the conversion. Example: +instead of a string. This function converts @var{string} into an array +of bytes of the UTF-8 encoding of @var{string}. Example: @lisp (dbus-string-to-byte-array "/etc/hosts") @@ -1154,11 +1154,11 @@ The signal @code{PropertyModified}, discussed as an example in (@var{integer} ((@var{string} @var{bool} @var{bool}) (@var{string} @var{bool} @var{bool}) @dots{})) @end lisp -@defun dbus-byte-array-to-string byte-array &optional multibyte +@defun dbus-byte-array-to-string byte-array If a D-Bus method or signal returns an array of bytes, which are known -to represent a UTF-8 string, this function converts @var{byte-array} -to the corresponding string. The string is unibyte encoded, unless -@var{multibyte} is non-@code{nil}. Example: +to represent a UTF-8 string, this function converts @var{byte-array} to +the corresponding Lisp string. The contents of @var{byte-array} should +be the byte sequence of a UTF-8 encoded string. Example: @lisp (dbus-byte-array-to-string '(47 101 116 99 47 104 111 115 116 115)) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index c7ab7e7bf21..0c7e3b09f41 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -2123,11 +2123,20 @@ to IRC, and don't forget that you can roll back to the previous version by running @kbd{M-x package-delete @key{RET}}. @xref{Packages,,,emacs, The Emacs Editor}, for more information. +Note that a bug affecting Emacs' packaging machinery may prevent the +above method from working on Emacs versions 29 and below. Users on 29 +can try running @kbd{C-u M-x package-install @key{RET}} instead. +Users on 28 and below can click on the @emph{installed} @samp{erc} +line item in the @file{*Packages*} buffer instead of the newest one, +and then, in the resulting @code{help-mode} buffer, find and activate +the button for the newest version, which should appear in the summary +item @samp{Other versions}. + In the rare instance you need an emergency fix or have volunteered to test an edge feature between ERC releases, you can try adding @samp{("devel" . "https://elpa.gnu.org/devel/")} to @code{package-archives} prior to performing the steps above. For -this, you'll want to instead select a ``snapshot'' version from the +this, you'll want to instead select a @dfn{snapshot} version from the menu. Please be aware that when going this route, the latest changes may not yet be available and you run the risk of incurring other bugs and encountering unstable features. diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 8767de71496..cecde5f3232 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -786,7 +786,6 @@ Here's a more complicated test: @end lisp @findex make-ert-test -@findex ert-equal-including-properties This test creates a test object using @code{make-ert-test} whose body will immediately signal failure. It then runs that test and asserts that it fails. Then, it creates a temporary buffer and invokes @@ -795,7 +794,7 @@ to the current buffer. Finally, it extracts the first line from the buffer and asserts that it matches what we expect. It uses @code{buffer-substring-no-properties} and @code{equal} to ignore text properties; for a test that takes properties into account, -@code{buffer-substring} and @code{ert-equal-including-properties} +@code{buffer-substring} and @code{equal-including-properties} could be used instead. The reason why this test only checks the first line of the backtrace diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 84a74a9d6ab..7019f4b2ca0 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -309,6 +309,12 @@ reported. A custom face for highlighting regions for which a note has been reported. +@item flymake-indicator-type +The indicator type which Flymake should use to indicate lines with +errors or warnings. +Depending on your preference, this can either use @code{fringes} or +@code{margins} for indicating errors. + @item flymake-error-bitmap A bitmap used in the fringe to mark lines for which an error has been reported. @@ -320,6 +326,18 @@ been reported. @item flymake-fringe-indicator-position Which fringe (if any) should show the warning/error bitmaps. +@item flymake-margin-indicators-string +Specifies the string and face to use for the margin indicators, for +each error type. + +@item flymake-margin-indicator-position +Which margin (if any) should show the warning/error strings. + +@item flymake-autoresize-margins +If non-@code{nil}, Flymake will resize the margins when +@code{flymake-mode} is turned on or off. +Only relevant if @code{flymake-indicator-type} is set to @code{margins}. + @item flymake-wrap-around If non-@code{nil}, moving to errors with @code{flymake-goto-next-error} and @code{flymake-goto-prev-error} wraps around buffer boundaries. @@ -388,6 +406,14 @@ variables}). It is overridden by any @code{before-string} overlay property. @item +@cindex margin of diagnostic +@code{flymake-margin-string}, a string displayed in the margin +according to @code{flymake-margin-indicator-position}. +The value actually follows the syntax of @code{flymake-margin-indicators-string} +(@pxref{Customizable variables}). It is overridden by any +@code{before-string} overlay property. + +@item @code{flymake-overlay-control}, an alist ((@var{OVPROP} . @var{VALUE}) @var{...}) of further properties used to affect the appearance of Flymake annotations. With the exception of @code{category} and diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 419a5390374..c5e4c885ccf 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -715,6 +715,7 @@ Browsing the Web * Web Searches:: Creating groups from articles that match a string. * RSS:: Reading RDF site summary. +* Atom:: Reading Atom Syndication Format feeds. Other Sources @@ -975,6 +976,7 @@ Back End Interface * Writing New Back Ends:: Extending old back ends. * Hooking New Back Ends Into Gnus:: What has to be done on the Gnus end. * Mail-like Back Ends:: Some tips on mail back ends. +* Web Feed Back Ends:: Easily defining back ends for web feeds. Various File Formats @@ -7421,6 +7423,22 @@ meaningful. Here's one example: header)))) @end lisp +And another example: the protonmail bridge adds fake message-ids to +@code{References} in message headers, which can confuse threading. To +remove these spurious ids + +@lisp +(setq gnus-alter-header-function 'fix-protonmail-references) + +(defun fix-protonmail-references (header) + (setf (mail-header-references header) + (mapconcat + #'(lambda (x) (if (string-search "protonmail.internalid" x) "" x)) + (gnus-split-references (mail-header-references header)) " ")) + header) + + @end lisp + @end table @@ -17252,6 +17270,7 @@ interfaces to these sources. @menu * Web Searches:: Creating groups from articles that match a string. * RSS:: Reading RDF site summary. +* Atom:: Reading Atom Syndication Format feeds. @end menu The main caveat with all these web sources is that they probably won't @@ -17496,6 +17515,42 @@ Parameters}) in order to display @samp{text/html} parts only in @end lisp +@node Atom +@subsection Atom +@cindex nnatom +@cindex Atom + +Some web sites provide an Atom Syndication Format feed. Atom is a web +feed format similar in function to RDF Site Summary (@pxref{RSS}). + +The @code{nnatom} back end allows you to add HTTP or local Atom feeds as +Gnus servers, by adding them to @code{gnus-secondary-select-methods} or +as foreign servers by pressing "B" in the @file{*Group*} buffer, for +example (@pxref{Finding the News}). The address of each server is its +feed's location (though the address shouldn't be prefixed with <http://> or +<https://>) and each server contains a single group which holds the +feed's entries. + +Features of @code{nnatom} include: + +@itemize @bullet + +@item +Server data is saved per-server in the @file{atom} sub-directory of +@file{gnus-directory}. + +@item +An article part is generated for both the summary and the content for +each entry in the feed. Content of all MIME types should be displayed +correctly through Gnus (as long as they are supported and the feed +specifies a MIME type). + +@item +Article modification and publish dates are tracked, and articles are +updated if changed. + +@end itemize + @node Other Sources @section Other Sources @@ -29997,6 +30052,7 @@ In the examples and definitions I will refer to the imaginary back end * Writing New Back Ends:: Extending old back ends. * Hooking New Back Ends Into Gnus:: What has to be done on the Gnus end. * Mail-like Back Ends:: Some tips on mail back ends. +* Web Feed Back Ends:: Easily defining back ends for web feeds. @end menu @@ -30770,6 +30826,43 @@ this: @end example +@node Web Feed Back Ends +@subsubsection Web Feed Back Ends + +If you want to write a back end for a new type of web feed (RSS, +Atom), or some other type of feed, an ``abstract'' back end +(@code{nnfeed}) exists to enable the creation of such back ends with +minimal knowledge of Gnus. + +@code{nnfeed} defines a generic parser, which uses functions stored in +server variables to parse information from a feed (@code{nnfeed} +itself doesn't actually define any such functions though). + +The data parsed from the feed is stored in server variables (and +stored per-feed in a sub-directory of @option{gnus-directory} whose name +corresponds to the name of the back end). + +A Gnus back end interface is also defined, which uses the data parsed +from the feed. + +Therefore, a new back end only needs to inherit from @code{nnfeed}, +define (fairly) generic parsing functions for the feed type and setup +the required server variables. + +@code{nnfeed} was originally created to support Atom Syndication +Format feeds (@pxref{Atom}), but is very generic (as of writing this, +no standard web feed exists which can meaningfully use all the +features supported): it supports multiple groups contained in a single +feed, it allows for situations when the entire feed can't (or +shouldn't) be read ahead of time and it allows for very advanced +customization of the actual printing of articles from parsed data +(while providing a reasonably powerful default method). + +Further implementation details are available in the documentation +strings of the various @code{nnfeed-*} server variables and +the commentary and other comments of @file{nnfeed.el}. + + @node Score File Syntax @subsection Score File Syntax diff --git a/doc/misc/reftex.texi b/doc/misc/reftex.texi index 5adc616e798..623e10e095f 100644 --- a/doc/misc/reftex.texi +++ b/doc/misc/reftex.texi @@ -4507,7 +4507,7 @@ In order to configure this variable, you can either set @code{reftex-cite-format} directly yourself or set it to the @emph{symbol} of one of the predefined styles. The predefined symbols are those which have an association in the constant -@code{reftex-cite-format-builtin}) E.g.: @code{(setq reftex-cite-format +@code{reftex-cite-format-builtin}, e.g.: @code{(setq reftex-cite-format 'natbib)}. @end defopt diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 131a23b7423..2b0a982e7f9 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -119,6 +119,7 @@ Installing @value{tramp} with your Emacs Configuring @value{tramp} for use +* Optional methods:: Optional methods which must be enabled first. * Connection types:: Types of connections to remote hosts. * Inline methods:: Inline methods. * External methods:: External methods. @@ -685,6 +686,7 @@ to non-@code{nil}, @xref{Directory Variables, , , emacs}. @menu +* Optional methods:: Optional methods which must be enabled first. * Connection types:: Types of connections to remote hosts. * Inline methods:: Inline methods. * External methods:: External methods. @@ -718,6 +720,30 @@ on the remote host. @end menu +@node Optional methods +@section Optional methods which must be enabled first +@cindex optional methods + +Not all methods are enabled by default after loading @value{tramp}. +Some of them don't work on the local host. Some of them are optional, +and must be enabled if it is intended to use them. For all methods +described in this manual, it is indicated when the method is optional. + +@deffn Command tramp-enable-method method +This command enables the optional method @var{method}, a string. The +command can be invoked interactively like @kbd{M-x tramp-enable-method +@key{RET} toolbox @key{RET}}, with @option{toolbox} being an optional +method. +@end deffn + +If you want to enable an optional method permanently, add something +like this to your @file{.emacs} file: + +@lisp +(with-eval-after-load 'tramp (tramp-enable-method "toolbox")) +@end lisp + + @node Connection types @section Types of connections to remote hosts @cindex connection types, overview @@ -834,6 +860,9 @@ equivalent @option{androidsu} method is provided for that system with workarounds for its many idiosyncrasies, with the exception that multi-hops are unsupported. +This is an optional method, @ref{Optional methods}. It is enabled by +default on @code{android} systems only. + @item @option{sudo} @cindex method @option{sudo} @cindex @option{sudo} method @@ -894,12 +923,15 @@ missing shell prompts that confuses @value{tramp}. This method is also similar to @option{ssh}. It uses the @command{krlogin -x} command only for remote host login. +This method is an optional method, @ref{Optional methods}. + @item @option{ksu} @cindex method @option{ksu} @cindex @option{ksu} method @cindex kerberos (with @option{ksu} method) -This is another method from the Kerberos suite. It behaves like @option{su}. +This is another method from the Kerberos suite. It behaves like +@option{su}. It is an optional method, @ref{Optional methods}. @item @option{plink} @cindex method @option{plink} @@ -960,7 +992,8 @@ a container's name or ID, as returned by @samp{toolbox list -c}. Without a host name, the default Toolbox container for the host will be used. -This method does not support user names. +This is an optional method, @ref{Optional methods}. It does not +support user names. @item @option{flatpak} @cindex method @option{flatpak} @@ -970,7 +1003,18 @@ Integration of Flatpak sandboxes. The host name may be either an application ID, a sandbox instance ID, or a PID, as returned by @samp{flatpak ps}. -This method does not support user names. +This is an optional method, @ref{Optional methods}. It does not +support user names. + +@item @option{apptainer} +@cindex method @option{apptainer} +@cindex @option{apptainer} method + +Integration of Apptainer instances. The host name is the instance +name, as returned by @samp{apptainer instance list}. + +This is an optional method, @ref{Optional methods}. It does not +support user names. @end table @@ -1110,6 +1154,8 @@ The command used for this connection is: @samp{fsh @var{host} -l not useful for @value{tramp}. @command{fsh} connects to remote host and @value{tramp} keeps that one connection open. +This is an optional method, @ref{Optional methods}. + @item @option{nc} @cindex method @option{nc} @cindex @option{nc} method @@ -1121,6 +1167,8 @@ NAS hosts. These dumb devices have severely restricted local shells, such as the @command{busybox} and do not host any other encode or decode programs. +This is an optional method, @ref{Optional methods}. + @item @option{sudoedit} @cindex method @option{sudoedit} @cindex @option{sudoedit} method @@ -5444,7 +5492,7 @@ HISTFILE=/dev/null Where are remote files trashed to? @vindex remote-file-name-inhibit-delete-by-moving-to-trash -Emacs can trash file instead of deleting +Emacs can trash files instead of deleting @ifinfo them, @ref{Misc File Ops, Trashing , , emacs}. @end ifinfo @@ -5456,6 +5504,29 @@ option @code{remote-file-name-inhibit-delete-by-moving-to-trash} is non-@code{nil}, or it is a remote encrypted file (@pxref{Keeping files encrypted}), which are deleted anyway. +@c Since Emacs 30. +@vindex trash-directory +If you want to trash a remote file into a remote trash directory, you +could configure the user option @code{trash-directory} to a +connection-local value. +@ifinfo +@xref{Connection Variables, , , emacs}. +@end ifinfo + +@lisp +@group +(connection-local-set-profile-variables + 'remote-trash-directory + '((trash-directory . "/sudo::~/.local/share/Trash"))) +@end group + +@group +(connection-local-set-profiles + `(:application tramp :protocol "sudo" :machine ,system-name) + 'remote-trash-directory) +@end group +@end lisp + If Emacs is configured to use the XDG conventions for the trash directory, remote files cannot be restored with the respective tools, because those conventions don't specify remote paths. Such files must @@ -5888,6 +5959,28 @@ as above in your @file{~/.emacs}: @item +How to ignore errors when changing file attributes? + +@vindex tramp-inhibit-errors-if-setting-file-attributes-fail +Sometimes, for example while saving remote files, errors appear when +changing file attributes like permissions, time stamps, or ownership. +If these errors can be ignored, set user option +@code{tramp-inhibit-errors-if-setting-file-attributes-fail} to a +non-@code{nil} value. This transforms the error into a warning. + + +@item +How to ignore errors when changing file attributes? + +@vindex tramp-inhibit-errors-if-setting-file-attributes-fail +Sometimes, for example while saving remote files, errors appear when +changing file attributes like permissions, time stamps, or ownership. +If these errors can be ignored, set user option +@code{tramp-inhibit-errors-if-setting-file-attributes-fail} to a +non-@code{nil} value. This transforms the error into a warning. + + +@item How to disable other packages from calling @value{tramp}? There are packages that call @value{tramp} without the user ever diff --git a/doc/misc/use-package.texi b/doc/misc/use-package.texi index d834e1be754..c2b6404b68b 100644 --- a/doc/misc/use-package.texi +++ b/doc/misc/use-package.texi @@ -1639,8 +1639,12 @@ For example, would try -- by invoking @code{package-vc-install} -- to install the latest commit of the package @code{foo} from the specified remote. -This can also be used for local packages, by combining it with the -@code{:load-path} (@pxref{Load path}) keyword: +@vindex use-package-vc-prefer-newest +Alternatively, the @code{use-package-vc-prefer-newest} user option +exists to always prefer the latest commit. + +The @code{:vc} keyword can also be used for local packages, by +combining it with @code{:load-path} (@pxref{Load path}): @example @group diff --git a/doc/misc/widget.texi b/doc/misc/widget.texi index cfb9d2211cf..2e378e86fc7 100644 --- a/doc/misc/widget.texi +++ b/doc/misc/widget.texi @@ -760,14 +760,14 @@ This chapter describes commands that are specific to buffers that contain widgets. @cindex widget keybindings -@defvr Const widget-keymap +@defvar widget-keymap Keymap containing useful bindings for buffers containing widgets. -Binds @key{TAB} and @kbd{C-@key{TAB}} to @code{widget-forward} and -@code{widget-backward}, respectively. It also binds @key{RET} to -@code{widget-button-press} and @kbd{down-mouse-1} and +Binds @key{TAB} to @code{widget-forward} and both @kbd{S-@key{TAB}} and +@kbd{M-@key{TAB}} to @code{widget-backward}. It also binds @key{RET} to +@code{widget-button-press} and both @kbd{down-mouse-1} and @kbd{down-mouse-2} to @code{widget-button-click}. -@end defvr +@end defvar There's also a keymap for events that the Widget library doesn't need to handle. @@ -788,42 +788,52 @@ The following navigation commands are available: @deffn Command widget-forward &optional count Move point @var{count} buttons or editing fields forward. @end deffn -@item @kbd{M-@key{TAB}} -@itemx @kbd{S-@key{TAB}} +@item M-@key{TAB} +@itemx S-@key{TAB} @deffn Command widget-backward &optional count Move point @var{count} buttons or editing fields backward. @end deffn @end table +@noindent +By default, tabbing can put point on an inactive widget. To skip over +inactive widgets when tabbing, set the user option +@code{widget-skip-inactive} to a non-@code{nil} value. +@xref{Customization}. When editing an @code{editable-field} widget, the following commands are available: @table @kbd -@item @key{C-e} +@item C-e @deffn Command widget-end-of-line Move point to the end of field or end of line, whichever is first. @end deffn -@item @kbd{C-k} +@item C-k @deffn Command widget-kill-line Kill to end of field or end of line, whichever is first. @end deffn -@item @kbd{M-TAB} +@item M-@key{TAB} +@itemx C-M-i @deffn Command widget-complete Complete the content of the editable field at point. @end deffn -@item @kbd{C-m} +@item C-m +@itemx @key{RET} @deffn Command widget-field-activate Invoke the editable field at point. @end deffn @end table -The following two are commands that can execute widget actions. +The following two commands can execute the action associated with a +button widget (e.g., a radio button or checkbox): + @table @kbd @item @key{RET} +@itemx C-m @findex widget-button-press @deffn Command widget-button-press @var{pos} &optional @var{event} Invoke the button at @var{pos}, defaulting to point. @@ -3257,14 +3267,26 @@ to get a string. Otherwise, it @code{eval}s it. This chapter is about the customization options for the Widget library, for the end user. -@deffn Face widget-field-face -Face used for other editing fields. +@deffn Face widget-documentation +Face used for documentation text. @end deffn -@deffn Face widget-button-face +@deffn Face widget-field +Face used for editable fields. +@end deffn + +@deffn Face widget-button Face used for buttons. @end deffn +@deffn Face widget-button-pressed +Face used for pressed buttons. +@end deffn + +@deffn Face widget-inactive +Face used for inactive widgets. +@end deffn + @defopt widget-mouse-face Face used for highlighting a button when the mouse pointer moves across it. @@ -3321,6 +3343,15 @@ If non-@code{nil}, toggle when there are just two options. By default, its value is @code{nil}. @end defopt +@defopt widget-skip-inactive +If non-@code{nil}, skip over inactive widgets when using @kbd{@key{TAB}} +(@code{widget-forward}) or @kbd{S-@key{TAB}} (@code{widget-backward}, +also bound to @kbd{M-@key{TAB}}) to navigate between widgets. + +By default, its value is @code{nil} and tabbing does not skip over +inactive widgets. +@end defopt + @defopt widget-documentation-links If non-@code{nil}, add hyperlinks to documentation strings. @end defopt diff --git a/etc/EGLOT-NEWS b/etc/EGLOT-NEWS index 12e7d3f6b9b..0e3e4b7aff8 100644 --- a/etc/EGLOT-NEWS +++ b/etc/EGLOT-NEWS @@ -20,6 +20,12 @@ https://github.com/joaotavora/eglot/issues/1234. * Changes in upcoming Eglot +** Disable workDoneProgress if eglot-report-progress is nil + +Eglot will now try to not register $/progress messages from the server +when the defcustom is set to nil. This requires a restart of the server +for the change to take effect. + * Changes in Eglot 1.17 (25/1/2024) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index d7f513addfb..b66ea6a7a02 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -486,16 +486,14 @@ these areas without inflicting collateral damage. Despite the rationale, this move admittedly ushers in a heightened potential for disruption because third-party members of ERC's modification hooks may not take kindly to encountering stamp-only -messages. They may also expect members of 'erc-insert-pre-hook' and -'erc-insert-done-hook' to run unconditionally, even though ERC -suppresses those hooks when inserting date stamps. Third parties may -also not appreciate that 'erc-timestamp-last-inserted-left' no longer -records the final trailing newline in 'erc-timestamp-format-left'. If -these inconveniences prove too encumbering to deal with right away, -see the escape hatch 'erc-stamp-prepend-date-stamps-p', which should -help ease the transition. As for detecting these new stamp-only -messages from members of 'erc-insert-modify-hook' and friends, see the -function 'erc-stamp-inserting-date-stamp-p'. +messages or the new behavior of 'erc-timestamp-last-inserted-left', +which no longer records the final trailing newline in the variable +'erc-timestamp-format-left'. If these inconveniences prove too +encumbering to deal with right away, see the escape hatch +'erc-stamp-prepend-date-stamps-p', which should help ease the +transition. As for detecting these new stamp-only messages from +members of 'erc-insert-modify-hook' and friends, see the function +'erc-stamp-inserting-date-stamp-p'. *** The role of a module's Custom group is now more clearly defined. Associating built-in modules with Custom groups and "provided" library @@ -15,6 +15,12 @@ in older Emacs versions. You can narrow news to a specific version by calling 'view-emacs-news' with a prefix argument or by typing 'C-u C-h C-n'. +Temporary note: ++++ indicates that all relevant manuals in doc/ have been updated. +--- means no change in the manuals is needed. +When you add a new item, use the appropriate mark if you are sure it +applies, and please also update docstrings as needed. + * Installation Changes in Emacs 30.1 @@ -43,6 +49,12 @@ external packages and to resolve potential incompatibilities between Linux and BSD versions of ALSA. Use '--with-sound=alsa' to build with ALSA on these operating systems instead. +--- +** Native JSON support is now always available; libjansson is no longer used. +No external library is required. The '--with-json' configure option has +been removed. 'json-available-p' now always returns non-nil and is only +kept for compatibility. + * Startup Changes in Emacs 30.1 @@ -62,11 +74,20 @@ more details. * Incompatible Changes in Emacs 30.1 +** Mouse wheel events should now always be 'wheel-up/down/left/right'. +At those places where the old 'mouse-4/5/6/7' events could still occur +(i.e., X11 input in the absence of XInput2, and 'xterm-mouse-mode'), +we remap them to the corresponding 'wheel-up/down/left/right' event, +according to the new variable 'mouse-wheel-buttons'. +The old variables 'mouse-wheel-up-event', 'mouse-wheel-down-event', +'mouse-wheel-left-event', and 'mouse-wheel-right-event' are thereby +obsolete. + ** Tree-Sitter modes are now declared as submodes of the non-TS modes. In order to help the use of those Tree-Sitter modes, they are now declared to have the corresponding non-Tree-Sitter mode as an additional parent. -This way, things like `.dir-locals.el` settings, and YASnippet +This way, things like ".dir-locals.el" settings, and YASnippet collections of snippets automatically apply to the new Tree-Sitter modes. Note that those modes still do not inherit from the non-TS mode, so @@ -111,7 +132,7 @@ to your init: ** 'describe-function' now shows the type of the function object. The text used to say things like "car is is a built-in function" whereas it now says "car is a primitive-function" where "primitive-function" -is the symbol returned by `cl-type-of` and you can click on it to get +is the symbol returned by 'cl-type-of' and you can click on it to get information about that type. ** 'advice-remove' is now an interactive command. @@ -150,7 +171,7 @@ This user option controls outline visibility in the output buffer of *** 'C-h m' ('describe-mode') uses outlining by default. Set 'describe-mode-outline' to nil to get back the old behavior. -** Outline Mode +** Outline mode +++ *** 'outline-minor-mode' is supported in tree-sitter major modes. @@ -251,7 +272,7 @@ value when installing GNU coreutils using something like ports or Homebrew. +++ -** cl-print +** CL Print +++ *** You can expand the "..." truncation everywhere. @@ -285,51 +306,102 @@ right-aligned to is controlled by the new user option ** Windows ++++ +*** New action alist entry 'category' for 'display-buffer'. +If the caller of 'display-buffer' passes '(category . symbol)' +in its 'action' argument, you can match the displayed buffer +by adding '(category . symbol)' to the condition part of +'display-buffer-alist' entries. + ++++ *** New action alist entry 'post-command-select-window' for 'display-buffer'. It specifies whether the window of the displayed buffer should be selected or deselected at the end of executing the current command. +--- +*** User option 'display-comint-buffer-action' is now obsolete. +You can use a '(category . comint)' condition in 'display-buffer-alist' +to match buffers displayed by comint-related commands. Another +user option 'display-tex-shell-buffer-action' is obsolete too +for which you can use '(category . tex-shell)'. + +++ *** New variable 'window-restore-killed-buffer-windows'. It specifies how 'set-window-configuration' and 'window-state-put' should proceed with windows whose buffer was killed after the corresponding configuration or state was recorded. +*** New variable 'window-point-context-set-function'. +It can be used to set a context for window point in all windows by +'window-point-context-set' before calling 'current-window-configuration' +and 'window-state-get'. Then later another new variable +'window-point-context-use-function' can be used by +'window-point-context-use' after 'set-window-configuration' and +'window-state-put' to restore positions of window points +according to the context stored in a window parameter. + ** Tab Bars and Tab Lines --- +*** New user option 'tab-bar-select-restore-context'. +It uses 'window-point-context-set' to save contexts where +window points were located before switching away from the tab, +and 'window-point-context-use' to restore positions of window +points after switching back to that tab. + +--- *** New user option 'tab-bar-select-restore-windows'. -It defines what to do with windows whose buffer was killed -since the tab was last selected. By default it displays -a placeholder buffer that provides information about the name -of the killed buffer that was displayed in that window. +It defines what to do with windows whose buffer was killed since the tab +was last selected. By default it displays a placeholder buffer +with the name " *Old buffer <name>*" that provides information about +the name of the killed buffer that was displayed in that window. --- *** New user option 'tab-bar-tab-name-format-functions'. -It can be used to add, remove and reorder functions that change -the appearance of every tab on the tab bar. +It can be used to add, remove and reorder functions that change the +appearance of every tab on the tab bar. --- *** New hook 'tab-bar-tab-post-select-functions'. -+++ -** New optional argument for modifying directory-local variables. -The commands 'add-dir-local-variable', 'delete-dir-local-variable' and -'copy-file-locals-to-dir-locals' now take an optional prefix argument, -to enter the file you want to modify. +--- +*** New keymap 'tab-bar-mode-map'. +By default it contains a keybinding 'C-TAB' to switch tabs, but only +when 'C-TAB' is not bound globally. You can unbind it if it conflicts +with 'C-TAB' in other modes. -** Miscellaneous +--- +*** New keymap 'tab-line-mode-map'. +By default it contains keybindings for switching tabs: 'C-x <left>', +'C-x <right>', 'C-x C-<left>', 'C-x C-<right>'. You can unbind them if +you want to use these keys for the commands 'previous-buffer' and +'next-buffer'. --- -*** New face 'appt-notification' for 'appt-display-mode-line'. -It can be used to customize the look of the appointment notification -displayed on the mode line when 'appt-display-mode-line' is non-nil. +*** Default list of tabs is changed to support a fixed order. +This means that 'tab-line-tabs-fixed-window-buffers', the new default +tabs function, is like the previous 'tab-line-tabs-window-buffers' where +both of them show only buffers that were previously displayed in the +window. But the difference is that the new function always keeps the +original order of buffers on the tab line, even after switching between +these buffers. You can drag the tabs and release at a new position +to manually reorder the buffers on the tab line. --- -*** Emacs now recognizes shebang lines that pass '-S'/'--split-string' to 'env'. -When visiting a script that invokes 'env -S INTERPRETER ARGS...' in -its shebang line, Emacs will now skip over 'env -S' and deduce the -major mode based on the interpreter after 'env -S'. +*** New user option 'tab-line-tabs-buffer-group-function'. +It provides two choices to group tab buffers by major mode and by +project name. + +--- +*** Buffers on group tabs are now sorted alphabetically. +This will keep the fixed order of tabs, even after switching between +them. + ++++ +** New optional argument for modifying directory-local variables. +The commands 'add-dir-local-variable', 'delete-dir-local-variable' and +'copy-file-locals-to-dir-locals' now take an optional prefix argument, +to enter the file name you want to modify. ** Emacs Server and Client @@ -361,6 +433,33 @@ Use 'TAB' in the minibuffer to show or hide the password. Likewise, there is an icon on the mode-line, which toggles the visibility of the password when clicking with 'mouse-1'. ++++ +** Support for styled underline face attributes. +These are implemented as new values of the 'style' attribute in a face +underline specification, 'double-line', 'dots', and 'dashes', and are +available on GUI systems. If your terminal's termcap or terminfo +database entry defines the 'Su' or 'Smulx' capability, Emacs will also +emit the prescribed escape sequence to render faces with such styles on +TTY frames. + +--- +** Support for underline colors on TTY frames. +Colors specified in face underlines will now also be displayed in TTY +frames with the previously mentioned capabilities. + +** Miscellaneous + +--- +*** New face 'appt-notification' for 'appt-display-mode-line'. +It can be used to customize the look of the appointment notification +displayed on the mode line when 'appt-display-mode-line' is non-nil. + +--- +*** Emacs now recognizes shebang lines that pass '-S'/'--split-string' to 'env'. +When visiting a script that invokes 'env -S INTERPRETER ARGS...' in +its shebang line, Emacs will now skip over 'env -S' and deduce the +major mode based on the interpreter after 'env -S'. + * Editing Changes in Emacs 30.1 @@ -447,7 +546,7 @@ By default this is disabled. --- *** Users in CJK locales can control width of some non-CJK characters. Some characters are considered by Unicode as "ambiguous" with respect -to their display width: either "full-width" (i.e. taking 2 columns on +to their display width: either "full-width" (i.e., taking 2 columns on display) or "narrow" (taking 1 column). The actual width depends on the fonts used for these characters by Emacs or (for text-mode frames) by the terminal emulator. Traditionally, font sets in CJK locales @@ -490,15 +589,15 @@ In batch mode, tracing now sends the trace to stdout. ** Mwheel The 'wheel-up/down/left/right' events are now bound unconditionally, and the 'mouse-wheel-up/down/left/right-event' variables are thus used -only to specify the 'mouse-4/5/6/7' events generated by older -configurations such as X11 when the X server does not support at least -version 2.1 of the X Input Extension, and 'xterm-mouse-mode'. +only to specify the 'mouse-4/5/6/7' events that might still +happen to be generated by some old packages (or if 'mouse-wheel-buttons' +has been set to nil). -** 'xterm-mouse-mode' +** Xterm Mouse mode This mode now emits 'wheel-up/down/right/left' events instead of 'mouse-4/5/6/7' events for the mouse wheel. -It uses the 'mouse-wheel-up/down/left/right-event' -variables to decide which button maps to which wheel event (if any). +It uses the new variable 'mouse-wheel-buttons' to decide which button +maps to which wheel event (if any). ** Info @@ -516,7 +615,7 @@ This requires the 'lzip' program to be installed on your system. ** New command 'lldb'. Run the LLDB debugger, analogous to the 'gud-gdb' command. -** gdb-mi +** GDB MI --- *** Variable order and truncation can now be configured in 'gdb-many-windows'. @@ -597,6 +696,12 @@ you can add this to your init script: (setopt project-switch-commands #'project-prefix-or-any-command) +--- +*** New variable 'project-files-relative-names'. +If it's non-nil, 'project-files' can return file names relative to the +project root. Project backends can use this to improve the performance +of their 'project-files' implementation. + ** VC --- @@ -934,6 +1039,13 @@ docstring, or a comment, or (re)indents the surrounding defun if point is not in a comment or a string. It is by default bound to 'M-q' in 'prog-mode' and all its descendants. +** Imenu + ++++ +*** New user option 'imenu-flatten'. +It defines whether to flatten the list of sections in an imenu +or show it nested. + ** Which Function mode +++ @@ -946,7 +1058,13 @@ mode line. 'header' will display in the header line; ** Tramp +++ -*** New connection method "androidsu". +*** Tramp methods can be optional. +An optional connection method is not enabled by default. The user must +enable it explicitly by the 'tramp-enable-method' command. The existing +methods "fcp", "krlogin", " ksu" and "nc" are optional now. + ++++ +*** New optional connection method "androidsu". This provides access to system files with elevated privileges granted by the idiosyncratic 'su' implementations and system utilities customary on Android. @@ -956,9 +1074,9 @@ Android. These are the external methods counterparts of "docker" and "podman". +++ -*** New connection methods "toolbox" and "flatpak". -They allow accessing system containers provided by Toolbox or -sandboxes provided by Flatpak. +*** New optional connection methods "toolbox", "flatpak" and "apptainer". +They allow accessing system containers provided by Toolbox, sandboxes +provided by Flatpak, or instances managed by Apptainer. +++ *** Connection method "kubernetes" supports now optional container name. @@ -1021,6 +1139,20 @@ for setting the remote PATH environment variable. ** EWW +--- +*** New mouse bindings in EWW buffers. +Certain form elements that were displayed as buttons, yet could only be +activated by keyboard input, are now operable using 'mouse-2'. With +"Submit" buttons, this triggers submission of the form, while clicks on +other classes of buttons either toggle their values or prompt for user +input, as the case may be. + +--- +*** EWW text input fields and areas are now fields. +In consequence, movement commands and OS input method features now +recognize and confine their activities to the text input field around +point. See also the Info node "(elisp) Fields". + +++ *** 'eww-open-file' can now display the file in a new buffer. By default, the command reuses the "*eww*" buffer, but if called with @@ -1054,13 +1186,13 @@ This is useful for continuing reading the URL in the current buffer when the new URL is fetched. --- -*** History navigation in EWW now works like other browsers. +*** History navigation in EWW now behaves as in other browsers. Previously, when navigating back and forward through page history, EWW would add a duplicate entry to the end of the history list each time. This made it impossible to navigate to the "end" of the history list. Now, navigating through history in EWW simply changes your position in the history list, allowing you to reach the end as expected. In -addition, when browsing to a new page from a "historical" one (i.e. a +addition, when browsing to a new page from a "historical" one (i.e., a page loaded by navigating back through history), EWW deletes the history entries newer than the current page. To change the behavior when browsing from "historical" pages, you can customize @@ -1084,7 +1216,7 @@ display only the readable parts by default. For more details, see When non-nil (the default), calling 'eww-readable' adds a new entry to the EWW page history. -** go-ts-mode +** Go-ts mode +++ *** New command 'go-ts-mode-docstring'. @@ -1165,6 +1297,28 @@ in a clean environment. ** Flymake +++ +*** New user option 'flymake-indicator-type'. +This user option controls which error indicator type Flymake should use +in current buffer. Depending on your preference, this can either use +fringes or margins for indicating errors. + ++++ +*** New user option 'flymake-margin-indicators-string'. +It controls, for each error type, the string and its face to display as +the margin indicator. + ++++ +*** New user option 'flymake-autoresize-margins'. +If non-nil, Flymake will resize the margins when 'flymake-mode' is +turned on or off. +Only relevant if 'flymake-indicator-type' is set to 'margins'. + ++++ +*** New user option 'flymake-margin-indicator-position'. +It controls which margin (left or right) is used for margin +indicators. + ++++ *** New user option 'flymake-show-diagnostics-at-end-of-line'. When non-nil, Flymake shows summarized descriptions of diagnostics at the end of the line. Depending on your preference, this can either be @@ -1212,14 +1366,46 @@ instead of: This allows the user to specify command line arguments to the non interactive Python interpreter specified by 'python-interpreter'. -** use-package +*** New function 'python-shell-send-block'. +It sends the python block delimited by 'python-nav-beginning-of-block' +and 'python-nav-end-of-block' to the inferior Python process. + +** Inferior Python mode + +--- +*** Default value of 'python-shell-compilation-regexp-alist' is changed. +Support for Python's ExceptionGroup has been added, so in the Python +shell, the line indicating the source of error in the error messages +from ExceptionGroup will be recognized as well. + +** Scheme mode +Scheme mode now handles regular expression literal '#/regexp/' that is +available in some Scheme implementations. +Also, it should now handle nested sexp-comments. + +** Use package +++ *** New ':vc' keyword. This keyword enables the user to install packages using 'package-vc'. ++++ +*** New user option 'use-package-vc-prefer-newest'. +This allows the user to always install the newest commit of a package +when using the ':vc' keyword. + ** Gnus ++++ +*** New backend 'nnfeed'. +This allows backend developers to easily create new backends for web +feeds, as inheriting backends of 'nnfeed'. + ++++ +*** New backend 'nnatom'. +This allow users to add Atom Syndication Format feeds to Gnus as +servers. + *** The 'nnweb-type' option 'gmane' has been removed. The gmane.org website is, sadly, down since a number of years with no prospect of it coming back. Therefore, it is no longer valid to set @@ -1285,6 +1471,13 @@ name as a string. The new function 'dictionary-completing-read-dictionary' can be used to prompt with completion based on dictionaries that the server supports. +--- +*** The default value of 'dictionary-tooltip-dictionary' has changed. +The new default value is t, which means use the same dictionary as the +value of 'dictionary-default-dictionary'. The previous default value +was nil, which effectively disabled 'dictionary-tooltip-mode', even if +the mode was turned on. + ** Pp *** New 'pp-default-function' user option replaces 'pp-use-max-width'. @@ -1371,13 +1564,13 @@ without specifying a file, like this: ** Image +++ -*** Image :map property is now recomputed when image is transformed. +*** Image ':map' property is now recomputed when image is transformed. Now images with clickable maps work as expected after you run commands -such as `image-increase-size', `image-decrease-size', `image-rotate', -`image-flip-horizontally', and `image-flip-vertically'. +such as 'image-increase-size', 'image-decrease-size', 'image-rotate', +'image-flip-horizontally', and 'image-flip-vertically'. +++ -*** New user option 'image-recompute-map-p' +*** New user option 'image-recompute-map-p'. Set this option to nil to prevent Emacs from recomputing image maps. ** Image Dired @@ -1438,35 +1631,16 @@ The user option 'proced-auto-update-flag' can now be set to 2 additional values, which control automatic updates of Proced buffers that are not displayed in some window. -** Miscellaneous - ---- -*** Webjump now assumes URIs are HTTPS instead of HTTP. -For links in 'webjump-sites' without an explicit URI scheme, it was -previously assumed that they should be prefixed with "http://". Such -URIs are now prefixed with "https://" instead. - ---- -*** 'bug-reference-mode' now supports 'thing-at-point'. -Now, calling '(thing-at-point 'url)' when point is on a bug reference -will return the URL for that bug. +** Kmacro Menu mode +++ -*** New user option 'rcirc-log-time-format' -This allows for rcirc logs to use a custom timestamp format, than the -chat buffers use by default. - ---- -*** New user option 'Buffer-menu-group-by'. -It controls how buffers are divided into groups that are displayed with -headings using Outline minor mode. - -+++ -*** New command 'Buffer-menu-toggle-internal'. -This command toggles the display of internal buffers in Buffer Menu mode; -that is, buffers not visiting a file and whose names start with a space. -Previously, such buffers were never shown. This command is bound to 'I' -in Buffer Menu mode. +*** New mode 'kmacro-menu-mode' and new command 'list-keyboard-macros'. +The new command 'list-keyboard-macros' is the keyboard-macro version +of commands like 'list-buffers' and 'list-processes', creating a listing +of the currently existing keyboards macros using the new mode +'kmacro-menu-mode'. It allows rearranging the macros in the ring, +duplicating them, deleting them, and editing their counters, formats, +and keys. ** Customize @@ -1512,9 +1686,66 @@ buffer method is the default, which preserves previous behavior. *** New user option 'xwidget-webkit-disable-javascript'. This allows disabling JavaScript in xwidget Webkit sessions. +** Ls Lisp + +--- +*** 'ls-lisp--insert-directory' supports more long options of 'ls'. +'ls-lisp--insert-directory', the ls-lisp implementation of +'insert-directory', now supports the '--time=TIME' and '--sort=time' +options of GNU 'ls'. + +** Widget + ++++ +*** New user option 'widget-skip-inactive'. +If non-nil, moving point forward or backward between widgets by typing +'TAB' or 'S-TAB' skips over inactive widgets. The default value is nil. + +** Miscellaneous + +--- +*** Webjump now assumes URIs are HTTPS instead of HTTP. +For links in 'webjump-sites' without an explicit URI scheme, it was +previously assumed that they should be prefixed with "http://". Such +URIs are now prefixed with "https://" instead. + +--- +*** 'bug-reference-mode' now supports 'thing-at-point'. +Now, calling '(thing-at-point 'url)' when point is on a bug reference +will return the URL for that bug. + ++++ +*** New user option 'rcirc-log-time-format'. +This allows for rcirc logs to use a custom timestamp format, than the +chat buffers use by default. + +--- +*** New user option 'Buffer-menu-group-by'. +It controls how buffers are divided into groups that are displayed with +headings using Outline minor mode. + ++++ +*** New command 'Buffer-menu-toggle-internal'. +This command toggles the display of internal buffers in Buffer Menu mode; +that is, buffers not visiting a file and whose names start with a space. +Previously, such buffers were never shown. This command is bound to 'I' +in Buffer Menu mode. + * New Modes and Packages in Emacs 30.1 ++++ +** New package Track-Changes. +This library is a layer of abstraction above 'before-change-functions' +and 'after-change-functions' which provides a superset of +the functionality of 'after-change-functions': +- It provides the actual previous text rather than only its length. +- It takes care of accumulating and bundling changes until a time when + its client finds it convenient to react to them. +- It detects most cases where some changes were not properly + reported (calls to 'before/after-change-functions' that are + incorrectly paired, missing, etc...) and reports them adequately. + ** New major modes based on the tree-sitter library +++ @@ -1548,6 +1779,8 @@ sexp navigation more intuitive. This minor mode shows you symbol completion suggestions as you type, using an inline preview. New user options in the 'completion-preview' customization group control exactly when Emacs displays this preview. +'completion-preview-mode' is buffer-local, to enable it globally use +'global-completion-preview-mode'. --- ** The highly accessible Modus themes collection has eight items. @@ -1574,9 +1807,42 @@ forwards-compatibility Compat package from GNU ELPA. This allows built-in packages to use the library more effectively, and helps preventing the installation of Compat if unnecessary. ++++ +** New package PEG. +Emacs now includes a library for writing Parsing Expression +Grammars (PEG), an approach to text parsing that provides more structure +than regular expressions, but less complexity than context-free +grammars. The Info manual "(elisp) Parsing Expression Grammars" has +documentation and examples. + * Incompatible Lisp Changes in Emacs 30.1 ++++ +** Evaluating a 'lambda' returns an object of type 'interpreted-function'. +Instead of representing interpreted functions as lists that start with +either 'lambda' or 'closure', Emacs now represents them as objects +of their own 'interpreted-function' type, which is very similar +to 'byte-code-function' objects (the argument list, docstring, and +interactive forms are placed in the same slots). +Lists that start with 'lambda' are now used only for non-evaluated +functions (in other words, for source code), but for backward compatibility +reasons, 'functionp' still recognizes them as functions and you can +still call them as before. +Thus code that attempts to "dig" into the internal structure of an +interpreted function's object with the likes of 'car' or 'cdr' will +no longer work and will need to use 'aref' instead to extract its +various subparts (when 'interactive-form', 'documentation', and +'help-function-arglist' aren't adequate). + ++++ +** 'define-globalized-minor-mode' requires that modes use 'run-mode-hooks'. +Minor modes defined with 'define-globalized-minor-mode', such as +'global-font-lock-mode', will not be enabled any more in those buffers +whose major modes fail to use 'run-mode-hooks'. Major modes defined +with 'define-derived-mode' are not affected. 'run-mode-hooks' has been the +recommended way to run major mode hooks since Emacs 22. + --- ** Old derived.el functions removed. The following functions have been deleted because they were only used @@ -1694,9 +1960,29 @@ Use a float value for the first argument instead. Instead, use 'eshell-process-wait-time', which supports floating-point values. ++++ +** Conversion of strings to and from byte-arrays works with multibyte strings. +The functions 'dbus-string-to-byte-array' and +'dbus-byte-array-to-string' now accept and return multibyte Lisp +strings, encoding to UTF-8 and decoding from UTF-8 internally. This +means that the argument to 'dbus-byte-array-to-string' must be a valid +UTF-8 byte sequence, and the optional parameter MULTIBYTE of +'dbus-byte-array-to-string' is now obsolete and unused. The argument of +'dbus-string-to-byte-array' should be a regular Lisp string, not a +unibyte string. + * Lisp Changes in Emacs 30.1 +** New types 'closure' and 'interpreted-function'. +'interpreted-function' is the new type used for interpreted functions, +and 'closure' is the common parent type of 'interpreted-function' +and 'byte-code-function'. + +Those new types come with the associated new predicates 'closurep' and +`interpreted-function-p' as well as a new constructor +'make-interpreted-closure'. + ** New function 'help-fns-function-name'. For named functions, it just returns the name and otherwise it returns a short "unique" string that identifies the function. @@ -1708,18 +1994,18 @@ This function is like 'type-of' except that it sometimes returns a more precise type. For example, for nil and t it returns 'null' and 'boolean' respectively, instead of just 'symbol'. -** New functions `primitive-function-p` and `cl-functionp`. -`primitive-function-p` is like `subr-primitive-p` except that it returns +** New functions 'primitive-function-p' and 'cl-functionp'. +'primitive-function-p' is like 'subr-primitive-p' except that it returns t only if the argument is a function rather than a special-form, -and `cl-functionp` is like `functionp` except it return nil +and 'cl-functionp' is like 'functionp' except it returns nil for lists and symbols. ** Built-in types have now corresponding classes. -At the Lisp level, this means that things like (cl-find-class 'integer) +At the Lisp level, this means that things like '(cl-find-class 'integer)' will now return a class object, and at the UI level it means that things like 'C-h o integer RET' will show some information about that type. -** New var 'major-mode-remap-defaults' and function 'major-mode-remap'. +** New variable 'major-mode-remap-defaults' and function 'major-mode-remap'. The first is like Emacs-29's 'major-mode-remap-alist' but to be set by packages (instead of users). The second looks up those two variables. @@ -1752,6 +2038,13 @@ the backtrace and other dynamic state at the point of the error. See the Info node "(elisp) Handling Errors". +++ +** Tooltips on fringes. +It is now possible to provide tooltips on fringes by adding special text +properties 'left-fringe-help' and 'right-fringe-help'. See the "(elisp) +Special Properties" Info node in the Emacs Lisp Reference Manual for +more details. + ++++ ** New 'pop-up-frames' action alist entry for 'display-buffer'. This has the same effect as the variable of the same name and takes precedence over the variable when present. @@ -1761,6 +2054,9 @@ Mostly used internally to do a kind of topological sort of inheritance hierarchies. +++ +** 'drop' is now an alias for the function 'nthcdr'. + ++++ ** New polymorphic comparison function 'value<'. This function returns non-nil if the first argument is less than the second. It works for any two values of the same type with reasonable @@ -1852,6 +2148,11 @@ The new function 'haiku-notifications-notify' provides a subset of the capabilities of the 'notifications-notify' function in a manner analogous to 'w32-notification-notify'. +** New variable 'haiku-pass-control-tab-to-system'. +This sets whether Emacs should pass 'C-TAB' on to the system instead of +handling it, fixing a problem where window switching would not activate +if an Emacs frame had focus on the Haiku operation system. + +++ ** New value 'if-regular' for the REPLACE argument to 'insert-file-contents'. It results in 'insert-file-contents' erasing the buffer instead of @@ -1925,7 +2226,6 @@ It returns the last position of a marker in its buffer even if that buffer has been killed. ('marker-position' would return nil in that case.) - ** Functions and variables to transpose sexps +++ @@ -2162,8 +2462,25 @@ were used to customizing 'native-comp-async-report-warnings-errors' to nil or 'silent', we suggest that you now leave it at its default value, and see if you get only warnings that matter. +** Function 'declare' forms + ++++ +*** New 'type' function declaration. +The declaration '(type TYPE)' specifies the type of a function. +Example: + + (defun hello (x y) + (declare (type (function (integer boolean) string))) + ...) + +specifies that the function takes two arguments, an integer and a +boolean, and returns a string. This information can be used by the +native compiler to produce better code, but specifying an incorrect type +may lead to Emacs crashing. See the Info node "(elisp) Declare Form" +for further information. + +++ -** New function declaration and property 'important-return-value'. +*** New 'important-return-value' function declaration and property. The declaration '(important-return-value t)' sets the 'important-return-value' property which indicates that the function return value should probably not be thrown away implicitly. @@ -2274,16 +2591,16 @@ is the value of the property to context menus shown when clicking on the text which as this property. --- -** Detecting the end of an iteration of a keyboard macro +** Detecting the end of an iteration of a keyboard macro. 'read-event', 'read-char', and 'read-char-exclusive' no longer return -1 -when called at the end of an iteration of a the execution of a keyboard +when called at the end of an iteration of the execution of a keyboard macro. Instead, they will transparently continue reading available input (e.g., from the keyboard). If you need to detect the end of a macro iteration, check the following condition before calling one of the aforementioned functions: (and (arrayp executing-kbd-macro) - (>= executing-kbd-macro-index (length executing-kbd-macro)))) + (>= executing-kbd-macro-index (length executing-kbd-macro))) +++ ** 'vtable-update-object' updates an existing object with just two arguments. @@ -2294,6 +2611,74 @@ this case, would mean repeating the object in the argument list.) When replacing an object with a different one, passing both the new and old objects is still necessary. +** JSON + +--- +*** The parser keeps duplicated object keys in alist and plist output. +A JSON object such as '{"a":1,"a":2}' will now be translated into the +Lisp values '((a . 1) (a . 2))' or '(:a 1 :a 2)' if alist or plist +object types are requested. + +--- +*** The parser sometimes signals different types of errors. +It will now signal 'json-utf8-decode-error' for inputs that are not +correctly UTF-8 encoded. + +--- +*** The parser and encoder now accept arbitrarily large integers. +Previously, they were limited to the range of signed 64-bit integers. + +** New tree-sitter functions and variables for defining and using "things" + ++++ +*** New variable 'treesit-thing-settings'. +It allows modes to define "things" like 'defun', 'text', 'sexp', and +'sentence' for navigation commands and tree-traversal functions. + ++++ +*** New functions for navigating "things". +There are new navigation functions 'treesit-thing-prev', +'treesit-thing-next', 'treesit-navigate-thing', +'treesit-beginning-of-thing', and 'treesit-end-of-thing'. + ++++ +*** New functions 'treesit-thing-at', 'treesit-thing-at-point'. + ++++ +*** Tree-traversing functions. +The functions 'treesit-search-subtree', 'treesit-search-forward', +'treesit-search-forward-goto', and 'treesit-induce-sparse-tree' now +accept more kinds of predicates. Lisp programs can now use thing +symbols (defined in 'treesit-thing-settings') and any thing definitions +for the predicate argument. + +** Other tree-sitter function and variable changes + ++++ +*** 'treesit-parser-list' now takes additional optional arguments. +The additional arguments are LANGUAGE and TAG. If LANGUAGE is given, +only return parsers for that language. If TAG is given, only return +parsers with that tag. Note that passing nil as tag doesn't mean return +all parsers, but rather "all parsers with no tags". + ++++ +*** New function 'treesit-parser-changed-ranges'. +This function returns buffer regions that are affected by the last +buffer edits. + +*** New function 'treesit-add-font-lock-rules'. +This function helps users to add custom font-lock rules to a tree-sitter +major mode. + +--- +** The variable 'rx-constituents' is now obsolete. +Use 'rx-define', 'rx-let' and 'rx-let-eval' instead. + +--- +** 'defvar-keymap' can specify hints for 'repeat-mode'. +Using ':repeat (:hints ((command . "hint") ...))' will show +the hint string in the echo area together with repeatable keys. + * Changes in Emacs 30.1 on Non-Free Operating Systems diff --git a/etc/NEWS.unknown b/etc/NEWS.unknown new file mode 100644 index 00000000000..eafdc953cac --- /dev/null +++ b/etc/NEWS.unknown @@ -0,0 +1,31 @@ +This file contains mentions of functions and variables whose +version of introduction would otherwise be guessed incorrectly +by 'M-x describe-function'. + +Since much of early Emacs source history is lost, these versions are +conservative estimates: the actual version of first appearance may very +well be much earlier. + +* Changes in Emacs 19.7 +** 'defsubst' + +* Changes in Emacs 18.59 +** 'mark' + +* Changes in Emacs 13.8 +This may be the earliest surviving version with source code, although +damaged. See +https://github.com/larsbrinkhoff/emacs-history/decuslib.com/decus/vax85b/gnuemax + +** 'nthcdr' +** 'nreverse +** 'let*' +** 'rassq' +** '>=' +** 'transpose-sexps' +** 'buffer-modified-p' +** 'current-column' +** 'downcase' +** 'previous-line' +** 'catch', 'throw' +** 'count-lines' diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 19456640299..2922f5a384c 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -178,6 +178,32 @@ The relevant bug report is here: A workaround is to set XLIB_SKIP_ARGB_VISUALS=1 in the environment before starting Emacs, or run Emacs as root. +** Emacs built with xwidgets aborts when displaying WebKit xwidgets + +This happens, for example, when 'M-x xwidget-webkit-browse-url' +prompts for a URL and you type the URL at the prompt. + +The error message might look like this: + + X protocol error: GLXBadWindow on protocol request 151 + Serial no: 4286 + Failing resource ID (if any): 0x3c001c5 + Minor code: 32 + +This happens because starting from version 2.42.1, the WebKitGTK +developers discontinued support for off-screen windows, by presuming +that every window holding a WebView widget is an X server window +eligible for an OpenGL context. Emacs requires placing these widgets +within offscreen windows managed by GTK, for each xwidget might be +displayed in multiple distinct windows, and its contents must be +captured and reproduced within all of them if that be the case. + +To put this another way, WebKitGTK doesn't support displaying a single +widget more than once anymore. + +A possible workaround is to make sure xwidgets are not shown in more +than one window. + ** Emacs crashes with SIGTRAP when trying to start a WebKit xwidget. This could happen if the version of WebKitGTK installed on your system @@ -190,6 +216,28 @@ arguments you intend to pass to Emacs): $ SNAP=1 SNAP_NAME=1 SNAP_REVISION=1 emacs ... +** Emacs built with tree-sitter crashes when some *-ts-mode is turned on. + +The crash is in many cases an abort due to run-time detection of stack +smashing, and it happens when one of the *-ts-mode modes is turned on +in a buffer. + +The reason is that the tree-sitter library changed its Application +Binary Interface (ABI) between version 0.22.2 and 0.22.4, but did not +increment the ABI version number. Therefore, Emacs compiled with +tree-sitter versions before the change will try to use the shared +library after the change, and crash due to incompatibilities in the +ABI. + +Until and unless the tree-sitter developers release a library with an +updated ABI version, the solution is to rebuild Emacs with the actual +library with which it will be used. If you cannot rebuild Emacs, +downgrade your tree-sitter library to version 0.22.2 or older. + +The relevant tree-sitter issue is here: + + https://github.com/tree-sitter/tree-sitter/issues/3296 + ** Emacs crashes when you try to view a file with complex characters. One possible reason for this could be a bug in the libotf or the @@ -1603,6 +1651,18 @@ underlying functionality in plasmashell gets fully disabled as well. At least a restart of plasmashell is required for the clipboard history to be cleared. +*** XFCE: Selected frame loses focus + +This can happen, e.g., in Ediff: when you move between the differences +by typing 'n' or 'p' into the control frame, input focus unexpectedly +switches to the buffers where Emacs shows the differences, instead of +being left in the Ediff control frame. + +The reason is a bug in the window manager: it shifts input focus when +raising a frame. A workaround is to activate the "focus stealing +prevention" option of the window manager (in XFCE settings, under +"window manager tweaks", in the "focus" tab). + *** CDE: Frames may cover dialogs they created when using CDE. This can happen if you have "Allow Primary Windows On Top" enabled which @@ -2063,6 +2123,16 @@ For such programs to function again, Emacs must be run on an X server where the input extension is disabled, or alternatively be configured with the "--without-xinput2" option. +*** Scrolling with mouse-wheel lags in GTK3 builds. + +We don't know why this happens, but one workaround is to build Emacs +with a different toolkit. For example: + + ./configure --without-toolkit-scroll-bars --with-x-toolkit=athena + +This produces a build which uses Athena toolkit, and disables toolkit +scroll bars which could sometimes be slow. + * Runtime problems on character terminals ** The meta key does not work on xterm. @@ -3553,6 +3623,17 @@ The organization of the Settings app might disagree with that illustrated above, which if true you should consult the documentation or any search mechanism for it. +** Emacs is not compatible with the "Microsoft SwiftKey" input method. + +When enabled, windows are repeatedly recentered around earlier buffer +positions as they are scrolled. The underlying cause is that Microsoft +SwiftKey aggressively forces point towards word boundaries, which motion +is sometimes received and duly processed by Emacs after the window in +question has already been scrolled past its target position, with the +result that the next redisplay recenters the window around this outdated +position. There is no solution but installing a more +cooperative--and preferably free--input method. + * Build-time problems ** Configuration @@ -172,10 +172,6 @@ Change them to use report-emacs-bug. **** lm-report-bug **** tramp-bug **** c-submit-bug-report - -** Allow fringe indicators to display a tooltip -Provide a help-echo property? - ** Add a defcustom that supplies a function to name numeric backup files Like 'make-backup-file-name-function' for non-numeric backup files. diff --git a/java/AndroidManifest.xml.in b/java/AndroidManifest.xml.in index 563914fb02c..f1047ac41d8 100644 --- a/java/AndroidManifest.xml.in +++ b/java/AndroidManifest.xml.in @@ -31,7 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. --> android:versionName="@version@"> <!-- Paste in every permission in existence so Emacs can do - anything. --> + everything. --> <uses-permission android:name="android.permission.READ_CONTACTS" /> <uses-permission android:name="android.permission.WRITE_CONTACTS" /> @@ -95,8 +95,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. --> <uses-permission android:name="android.permission.READ_MEDIA_VIDEO" /> <uses-permission android:name="android.permission.READ_MEDIA_VISUAL_USER_SELECTED" /> <uses-permission android:name="android.permission.READ_PHONE_NUMBERS" /> - <uses-permission android:name="android.permission.READ_SMS" /> - <uses-permission android:name="android.permission.RECEIVE_MMS" /> <uses-permission android:name="android.permission.RECEIVE_WAP_PUSH" /> <uses-permission android:name="android.permission.SCHEDULE_EXACT_ALARM" /> <uses-permission android:name="android.permission.SMS_FINANCIAL_TRANSACTIONS" /> @@ -185,7 +183,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. --> <uses-permission android:name="android.permission.USE_EXACT_ALARM" /> <uses-permission android:name="android.permission.USE_FINGERPRINT" /> <uses-permission android:name="android.permission.WRITE_PROFILE" /> - <uses-permission android:name="android.permission.WRITE_SMS" /> <uses-permission android:name="android.permission.WRITE_SOCIAL_STREAM" /> <uses-permission android:name="android.permission.WRITE_SYNC_SETTINGS" /> <uses-permission android:name="android.permission.WRITE_USER_DICTIONARY" /> diff --git a/java/INSTALL b/java/INSTALL index f1063b40c25..94bf0b01a96 100644 --- a/java/INSTALL +++ b/java/INSTALL @@ -268,14 +268,13 @@ When building for Intel systems, some ``ndk-build'' modules require the Netwide Assembler, usually installed under ``nasm'', to be present on the system that is building Emacs. -Google, Inc. has adapted many common Emacs dependencies to use the -`ndk-build' system. Here is a non-exhaustive list of what is known to -work, along with what has to be patched to make them work: +Google has adapted several Emacs dependencies to use the `ndk-build' +system, many of which require patches to function under an Emacs +environment. As such, it is generally the wiser choice to use our ports +in their place, but the following list and patches are still provided +for reference. libpng - https://android.googlesource.com/platform/external/libpng - libwebp - https://android.googlesource.com/platform/external/webp - (You must apply the patch at the end of this file for the resulting - binary to work on armv7 devices.) giflib - https://android.googlesource.com/platform/external/giflib (You must add LOCAL_EXPORT_CFLAGS := -I$(LOCAL_PATH) before its Android.mk includes $(BUILD_STATIC_LIBRARY)) @@ -310,10 +309,9 @@ branches, and can be easily adapted to newer versions. In addition, some Emacs dependencies provide `ndk-build' support themselves: - libjansson - https://github.com/akheron/jansson - (You must add LOCAL_EXPORT_INCLUDES := $(LOCAL_C_INCLUDES) before - its Android.mk includes $(BUILD_SHARED_LIBRARY), then copy - android/jansson_config.h to android/jansson_private_config.h.) + libwebp - https://android.googlesource.com/platform/external/webp + (You must apply the patch at the end of this file for the resulting + binary to work on armv7 devices.) Emacs developers have ported the following dependencies to ARM Android systems: @@ -326,6 +324,15 @@ systems: (Please see the section TREE-SITTER near the end of this file.) harfbuzz - https://sourceforge.net/projects/android-ports-for-gnu-emacs (Please see the section HARFBUZZ near the end of this file.) + libxml2 - https://sourceforge.net/projects/android-ports-for-gnu-emacs + (Please see the section LIBXML2 near the end of this file.) + libjpeg-turbo - https://sourceforge.net/projects/android-ports-for-gnu-emacs + giflib - https://sourceforge.net/projects/android-ports-for-gnu-emacs + libtiff - https://sourceforge.net/projects/android-ports-for-gnu-emacs + libpng - https://sourceforge.net/projects/android-ports-for-gnu-emacs + (Please see the section IMAGE LIBRARIES near the end of this file.) + libselinux - https://sourceforge.net/projects/android-ports-for-gnu-emacs + (Please see the section SELINUX near the end of this file.) And other developers have ported the following dependencies to Android systems: @@ -353,14 +360,67 @@ To build Emacs with GnuTLS, you must unpack each of the following tar archives in that site: gmp-6.2.1-emacs.tgz - gnutls-3.7.8-emacs.tar.gz + gnutls-3.8.5-emacs.tar.gz + (or gnutls-3.8.5-emacs-armv7a.tar.gz on 32-bit systems) libtasn1-4.19.0-emacs.tar.gz p11-kit-0.24.1-emacs.tar.gz nettle-3.8-emacs.tar.gz -and add the resulting folders to ``--with-ndk-path''. Note that you -should not try to build these packages separately using any -`configure' script or Makefiles inside. +and add the resulting folders to ``--with-ndk-path''. Do not attempt to +build these packages separately by means of `configure' scripts or +Makefiles inside. + + +LIBXML2 + +A copy of libxml2 adapted for the same build system is provided under +the name: + + libxml2-2.12.4-emacs.tar.gz + +In contrast to the version distributed by Google, internationalization +is disabled, which eliminates the dependency on icu4c (and by extension +a C++ compiler). + + +IMAGE LIBRARIES + +ndk-build enabled versions of image libraries required by Emacs are also +provided as: + + giflib-5.2.1-emacs.tar.gz + libjpeg-turbo-3.0.2-emacs.tar.gz + libpng-1.6.41-emacs.tar.gz + tiff-4.5.0-emacs.tar.gz + +Of which all but libjpeg-turbo-3.0.2-emacs.tar.gz should compile on +every supported Android system and toolchain; where the latter does not +compile, i.e. old armeabi toolchains, Google's version is a suitable +substitute. + +Of the three remaining image-related dependencies, libwebp provides +upstream support for ndk-build, ImageMagick has been ported by +interested third-party developers, while librsvg2, with its numerous and +unnavigable web of dependencies and toolchains for non-C languages, +would be such a great undertaking to port that we do not anticipate its +ever becoming available. + +We are actively searching for alternatives to librsvg2 that are feasible +to port, or better yet, natively support Android. Please send +suggestions or patches to emacs-devel@gnu.org. + + +SELINUX + +The upstream version of libselinux is available as: + + libselinux-3.6-emacs.tar.gz + +and compiles on toolchains configured for Android 4.3 and later, which +are the earliest Android releases to support SELinux. Its principal +advantage over Google's edition is the absence of Android-specific +modifications that create dependencies on libpackagelistparser and +libcrypto; Google's pcre remains a requirement. TREE-SITTER @@ -380,7 +440,9 @@ A copy of HarfBuzz modified to build with the ndk-build system can also be found at that URL. To build Emacs with HarfBuzz, you must unpack the following tar archive in that site: - harfbuzz-7.1.0-emacs.tar.gz + harfbuzz-7.1.0-emacs.tar.gz (when building for Android >4.3 + with 21.0.x or later of the NDK) + harfbuzz-1.7.7.tar.gz (earlier NDK or platform releases) and add the resulting folder to ``--with-ndk-build''. diff --git a/java/Makefile.in b/java/Makefile.in index c23b52ed44e..35d2637837c 100644 --- a/java/Makefile.in +++ b/java/Makefile.in @@ -83,6 +83,10 @@ RESOURCE_FILES := $(foreach file,$(wildcard $(srcdir)/res/*), \ # code. Instead, it is automatically included by the Java compiler. RESOURCE_FILE := $(srcdir)/org/gnu/emacs/R.java +# EmacsConfig.java is a file that holds information regarding the set of +# shared libraries this binary links to, and similar build variables. +CONFIG_FILE := $(builddir)/org/gnu/emacs/EmacsConfig.java + # CLASS_FILES is what should actually be built and included in the # resulting Emacs executable. The Java compiler might generate more # than one class file for each source file, so this only serves as a @@ -98,6 +102,12 @@ JAVA_FILES := $(filter-out $(RESOURCE_FILE),$(JAVA_FILES)) ANDROID_MIN_SDK := @ANDROID_MIN_SDK@ APK_NAME := emacs-$(version)-$(ANDROID_MIN_SDK)-$(ANDROID_ABI).apk +# Whether or not the bundle is to be debuggable. +ANDROID_DEBUGGABLE := @ANDROID_DEBUGGABLE@ + +# Whether or not $(D8) is in fact the name of the `r8' optimizer binary. +IS_D8_R8 := @IS_D8_R8@ + # How this stuff works. # emacs.apk depends on emacs.apk-in, which is simply a ZIP archive @@ -187,10 +197,13 @@ install_temp: $(CROSS_BINS) $(CROSS_LIBS) $(RESOURCE_FILES) $(AM_V_SILENT) mkdir -p install_temp/assets/etc $(AM_V_SILENT) mkdir -p install_temp/assets/lisp $(AM_V_SILENT) mkdir -p install_temp/assets/info -# Install architecture independents to assets/etc and assets/lisp + $(AM_V_SILENT) mkdir -p install_temp/assets/bitmaps +# Install architecture independents to assets/etc, assets/lisp and +# assets/bitmaps $(AM_V_SILENT) cp -r $(top_srcdir)/lisp install_temp/assets $(AM_V_SILENT) cp -r $(top_srcdir)/etc install_temp/assets $(AM_V_SILENT) cp -r $(top_srcdir)/info install_temp/assets + $(AM_V_SILENT) cp -r $(top_srcdir)/src/bitmaps install_temp/assets # Replace etc/DOC generated by compiling Emacs for the build machine # with etc/DOC from the cross-compiled Emacs. $(AM_V_SILENT) test -f $(top_builddir)/cross/etc/DOC \ @@ -271,10 +284,10 @@ emacs.apk-in: install_temp install_temp/assets/directory-tree \ $(AM_V_SILENT) rm -rf install_temp # Makefile itself. -.PRECIOUS: $(top_srcdir)/config.status Makefile -$(top_srcdir)/config.status: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4 +.PRECIOUS: $(top_builddir)/config.status Makefile +$(top_builddir)/config.status: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4 $(MAKE) -C $(dir $@) $(notdir $@) -Makefile: $(top_srcdir)/config.status $(top_srcdir)/java/Makefile.in +Makefile: $(top_builddir)/config.status $(top_srcdir)/java/Makefile.in $(MAKE) -C .. java/$@ # AndroidManifest.xml: @@ -288,21 +301,100 @@ $(RESOURCE_FILE): $(RESOURCE_FILES) -J $(dir $@) -M AndroidManifest.xml \ -S $(top_srcdir)/java/res -# Make all class files depend on R.java being built. -$(CLASS_FILES): $(RESOURCE_FILE) +# Generate a list of libemacs's dependencies with each item ordered +# before its dependents for the startup process to load in advance, as +# older versions of the dynamic linker do not consider these libraries +# when resolving its imports. The several following statements are +# executed from a recursive `make' run after shared libraries are +# generated. + +ALL_DEPENDENCIES := + +ifneq (,$(filter cf-stamp-1,$(MAKECMDGOALS))) +# Don't be sidetracked by dependencies of shared libraries outside the +# ndk-build directory. +define get-dependencies +$(foreach x, \ +$(and $(wildcard $(top_builddir)/cross/ndk-build/$1.so), \ + $(shell $(NDK_BUILD_READELF) -d \ + $(wildcard $(top_builddir)/cross/ndk-build/$1.so) \ + | sed -n 's/.*(NEEDED).*\[\(.*\.so\)\].*/\1/p')), \ +$(basename $(notdir $(x)))) +endef #get-dependencies +define resolve-one-dependency +$(foreach dependency,$(call get-dependencies,$1),\ + $(if $(findstring "$(dependency)",$(ALL_DEPENDENCIES)),,\ + $(call resolve-one-dependency,$(basename $(notdir $(dependency)))) \ + $(eval ALL_DEPENDENCIES := $(ALL_DEPENDENCIES) "$(dependency)",))) +endef #resolve-one-dependency +DEPENDENCIES := $(foreach file,$(NDK_BUILD_SHARED),\ + $(basename $(notdir $(file)))) +$(foreach file,$(DEPENDENCIES),\ + $(if $(findstring "$(file)",$(ALL_DEPENDENCIES)),,\ + $(call resolve-one-dependency,$(file)) \ + $(eval ALL_DEPENDENCIES := $(ALL_DEPENDENCIES) "$(file)",))) +endif + +# EmacsConfig.java: +ifeq (${V},1) +AM_V_EMACSCONFIG = +else +AM_V_EMACSCONFIG = @$(info $. GEN org/gnu/emacs/EmacsConfig.java) +endif + +.PHONY: cf-stamp-1 +cf-stamp-1: + $(AM_V_at) echo 'package org.gnu.emacs;\ +public class EmacsConfig\ +{\ +/* This is a generated file. Do not edit! */\ +public static final String[] EMACS_SHARED_LIBRARIES\ += {$(ALL_DEPENDENCIES)};\ +}' | sed 's/\\//g' > globals.tmp + $(AM_V_at) mkdir -p org/gnu/emacs + $(AM_V_at) $(top_srcdir)/build-aux/move-if-change \ + globals.tmp org/gnu/emacs/EmacsConfig.java + +# cf-stamp-1 is a phony target invoked in a second `make' instance after +# all shared libraries are compiled, because the computation of +# ALL_DEPENDENCIES in this instance of Make cannot be postponed until +# that stage. +cf-stamp: $(NDK_BUILD_SHARED) $(CROSS_LIBS) + $(AM_V_EMACSCONFIG) $(MAKE) cf-stamp-1 + $(AM_V_at) touch $@ +$(CONFIG_FILE): cf-stamp; @true + +# Make all class files depend on R.java and EmacsConfig.java being +# built. +$(CLASS_FILES): $(RESOURCE_FILE) $(CONFIG_FILE) .SUFFIXES: .java .class $(CLASS_FILES) &: $(JAVA_FILES) - $(AM_V_JAVAC) $(JAVAC) $(JAVAFLAGS) $(JAVA_FILES) + $(AM_V_JAVAC) $(JAVAC) $(JAVAFLAGS) $(JAVA_FILES) $(CONFIG_FILE) $(AM_V_SILENT) touch $(CLASS_FILES) # N.B. that find must be called all over again in case javac generated # nested classes. -classes.dex: $(CLASS_FILES) +ALL_CLASS_FILES = \ + $(subst $$,\$$,$(shell find $(srcdir) -type f -name *.class)) +ALL_CLASS_FILES_1 = + +ifneq ($(builddir),$(srcdir)) +# If the build directory is distinct from the source directory, also +# include generated class files located there. +ALL_CLASS_FILES_1 = \ + $(subst $$,\$$,$(shell find $(builddir) -type f -name *.class)) +endif + +classes.dex: $(CLASS_FILES) $(if $(IS_D8_R8), $(srcdir)/proguard.conf) $(AM_V_D8) $(D8) --classpath $(ANDROID_JAR) \ - $(subst $$,\$$,$(shell find $(srcdir) -type f \ - -name *.class)) --output $(builddir) + $(ALL_CLASS_FILES) $(ALL_CLASS_FILES_1) \ + --output $(builddir) \ + --min-api $(ANDROID_MIN_SDK) \ + $(if $(filter false,$(ANDROID_DEBUGGABLE)),--release, \ + --debug) \ + $(if $(IS_D8_R8),--pg-conf $(srcdir)/proguard.conf) # When emacs.keystore expires, regenerate it with: # @@ -335,7 +427,8 @@ TAGS: $(ETAGS) $(tagsfiles) $(AM_V_GEN) $(ETAGS) $(tagsfiles) clean: - rm -f *.apk emacs.apk-in *.dex *.unaligned *.class *.idsig + rm -f *.apk emacs.apk-in *.dex *.unaligned *.class *.idsig \ + cf-stamp $(CONFIG_FILE) rm -rf install-temp $(RESOURCE_FILE) TAGS find . -name '*.class' $(FIND_DELETE) diff --git a/java/org/gnu/emacs/EmacsActivity.java b/java/org/gnu/emacs/EmacsActivity.java index e380b7bfc2a..118c3375ad5 100644 --- a/java/org/gnu/emacs/EmacsActivity.java +++ b/java/org/gnu/emacs/EmacsActivity.java @@ -50,11 +50,14 @@ import android.view.WindowInsetsController; import android.widget.FrameLayout; public class EmacsActivity extends Activity - implements EmacsWindowAttachmentManager.WindowConsumer, + implements EmacsWindowManager.WindowConsumer, ViewTreeObserver.OnGlobalLayoutListener { public static final String TAG = "EmacsActivity"; + /* Key of intent value providing extra startup argument. */ + public static final String EXTRA_STARTUP_ARGUMENTS; + /* ID for URIs from a granted document tree. */ public static final int ACCEPT_DOCUMENT_TREE = 1; @@ -88,6 +91,7 @@ public class EmacsActivity extends Activity static { focusedActivities = new ArrayList<EmacsActivity> (); + EXTRA_STARTUP_ARGUMENTS = "org.gnu.emacs.STARTUP_ARGUMENTS"; }; public static void @@ -207,6 +211,18 @@ public class EmacsActivity extends Activity public final void destroy () { + if (window != null) + { + /* Clear the window's pointer to this activity and remove the + window's view. */ + window.setConsumer (null); + + /* The window can't be iconified any longer. */ + window.noticeDeiconified (); + layout.removeView (window.view); + window = null; + } + finish (); } @@ -218,7 +234,7 @@ public class EmacsActivity extends Activity } @Override - public final void + public void onCreate (Bundle savedInstanceState) { FrameLayout.LayoutParams params; @@ -230,8 +246,8 @@ public class EmacsActivity extends Activity /* See if Emacs should be started with any extra arguments, such as `--quick'. */ intent = getIntent (); - EmacsService.extraStartupArgument - = intent.getStringExtra ("org.gnu.emacs.STARTUP_ARGUMENT"); + EmacsService.extraStartupArguments + = intent.getStringArrayExtra (EXTRA_STARTUP_ARGUMENTS); matchParent = FrameLayout.LayoutParams.MATCH_PARENT; params @@ -249,7 +265,7 @@ public class EmacsActivity extends Activity EmacsService.startEmacsService (this); /* Add this activity to the list of available activities. */ - EmacsWindowAttachmentManager.MANAGER.registerWindowConsumer (this); + EmacsWindowManager.MANAGER.registerWindowConsumer (this); /* Start observing global layout changes between Jelly Bean and Q. This is required to restore the fullscreen state whenever the @@ -326,16 +342,16 @@ public class EmacsActivity extends Activity public final void onDestroy () { - EmacsWindowAttachmentManager manager; - boolean isMultitask; + EmacsWindowManager manager; + boolean isMultitask, reallyFinishing; - manager = EmacsWindowAttachmentManager.MANAGER; + manager = EmacsWindowManager.MANAGER; /* The activity will die shortly hereafter. If there is a window attached, close it now. */ isMultitask = this instanceof EmacsMultitaskActivity; - manager.removeWindowConsumer (this, (isMultitask - || isReallyFinishing ())); + reallyFinishing = isReallyFinishing (); + manager.removeWindowConsumer (this, isMultitask || reallyFinishing); focusedActivities.remove (this); invalidateFocus (2); @@ -383,7 +399,7 @@ public class EmacsActivity extends Activity { isPaused = true; - EmacsWindowAttachmentManager.MANAGER.noticeIconified (this); + EmacsWindowManager.MANAGER.noticeIconified (this); super.onPause (); } @@ -394,7 +410,7 @@ public class EmacsActivity extends Activity isPaused = false; timeOfLastInteraction = 0; - EmacsWindowAttachmentManager.MANAGER.noticeDeiconified (this); + EmacsWindowManager.MANAGER.noticeDeiconified (this); super.onResume (); } @@ -428,8 +444,7 @@ public class EmacsActivity extends Activity if (!EmacsContextMenu.itemAlreadySelected) { serial = EmacsContextMenu.lastMenuEventSerial; - EmacsNative.sendContextMenu ((short) 0, 0, - serial); + EmacsNative.sendContextMenu (0, 0, serial); } super.onContextMenuClosed (menu); @@ -538,6 +553,14 @@ public class EmacsActivity extends Activity EmacsNative.sendNotificationAction (tag, action); } + + @Override + public long + getAttachmentToken () + { + return -1; /* This is overridden by EmacsMultitaskActivity. */ + } + @Override diff --git a/java/org/gnu/emacs/EmacsClipboard.java b/java/org/gnu/emacs/EmacsClipboard.java index 9db436ca1e2..86553f478ed 100644 --- a/java/org/gnu/emacs/EmacsClipboard.java +++ b/java/org/gnu/emacs/EmacsClipboard.java @@ -19,6 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ package org.gnu.emacs; +import android.content.res.AssetFileDescriptor; import android.os.Build; /* This class provides helper code for accessing the clipboard, @@ -31,8 +32,8 @@ public abstract class EmacsClipboard public abstract boolean clipboardExists (); public abstract byte[] getClipboard (); - public abstract byte[][] getClipboardTargets (); - public abstract long[] getClipboardData (byte[] target); + public abstract String[] getClipboardTargets (); + public abstract AssetFileDescriptor getClipboardData (String target); /* Create the correct kind of clipboard for this system. */ diff --git a/java/org/gnu/emacs/EmacsContextMenu.java b/java/org/gnu/emacs/EmacsContextMenu.java index 2bbf2a313d6..365a7ec40af 100644 --- a/java/org/gnu/emacs/EmacsContextMenu.java +++ b/java/org/gnu/emacs/EmacsContextMenu.java @@ -108,8 +108,8 @@ public final class EmacsContextMenu will normally confuse Emacs into thinking that the context menu has been dismissed. Wrong! - Setting this flag makes EmacsActivity to only handle - SubMenuBuilder being closed, which always means the menu + Setting this flag prompts EmacsActivity to only handle + SubMenuBuilders being closed, which always means the menu has actually been dismissed. However, these extraneous events aren't sent on devices @@ -121,8 +121,7 @@ public final class EmacsContextMenu } /* Send a context menu event. */ - EmacsNative.sendContextMenu ((short) 0, itemID, - lastMenuEventSerial); + EmacsNative.sendContextMenu (0, itemID, lastMenuEventSerial); /* Say that an item has already been selected. */ itemAlreadySelected = true; diff --git a/java/org/gnu/emacs/EmacsCursor.java b/java/org/gnu/emacs/EmacsCursor.java index 1049c03d7da..e5f22c23cfc 100644 --- a/java/org/gnu/emacs/EmacsCursor.java +++ b/java/org/gnu/emacs/EmacsCursor.java @@ -31,9 +31,9 @@ public final class EmacsCursor extends EmacsHandleObject public final PointerIcon icon; public - EmacsCursor (short handle, int glyph) + EmacsCursor (int glyph) { - super (handle); + super (); if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N) { diff --git a/java/org/gnu/emacs/EmacsDialog.java b/java/org/gnu/emacs/EmacsDialog.java index 0d5b650f7d0..31b2969197e 100644 --- a/java/org/gnu/emacs/EmacsDialog.java +++ b/java/org/gnu/emacs/EmacsDialog.java @@ -93,7 +93,7 @@ public final class EmacsDialog implements DialogInterface.OnDismissListener onClick (View view) { wasButtonClicked = true; - EmacsNative.sendContextMenu ((short) 0, id, menuEventSerial); + EmacsNative.sendContextMenu (0, id, menuEventSerial); dismissDialog.dismiss (); } @@ -102,7 +102,7 @@ public final class EmacsDialog implements DialogInterface.OnDismissListener onClick (DialogInterface dialog, int which) { wasButtonClicked = true; - EmacsNative.sendContextMenu ((short) 0, id, menuEventSerial); + EmacsNative.sendContextMenu (0, id, menuEventSerial); } }; @@ -414,6 +414,6 @@ public final class EmacsDialog implements DialogInterface.OnDismissListener if (wasButtonClicked) return; - EmacsNative.sendContextMenu ((short) 0, 0, menuEventSerial); + EmacsNative.sendContextMenu (0, 0, menuEventSerial); } }; diff --git a/java/org/gnu/emacs/EmacsDrawLine.java b/java/org/gnu/emacs/EmacsDrawLine.java index 61b7d54d63c..c3399b4a75e 100644 --- a/java/org/gnu/emacs/EmacsDrawLine.java +++ b/java/org/gnu/emacs/EmacsDrawLine.java @@ -25,6 +25,97 @@ import android.graphics.Rect; public final class EmacsDrawLine { + /* Return the normalized slope and magnitude of a line whose extrema + are DX and DY removed, on the X and Y axes respectively, from its + origin point. */ + + private static float[] + measureLine (float dx, float dy) + { + float hypot; + + if (dx == 0f && dy == 0f) + return new float[] { 0f, 0f, 0f, }; + + if (dx == 0f) + return new float[] { 0f, dy > 0f ? 1f : -1f, Math.abs (dy), }; + else if (dy == 0f) + return new float[] { dx > 0f ? 1f : -1f, 0f, Math.abs (dx), }; + else + { + hypot = (float) Math.hypot (dx, dy); + return new float[] { dx / hypot, dy / hypot, hypot, }; + } + } + + private static void + polyDashPattern (EmacsGC gc, Canvas canvas, Paint paint, float x0, + float y0, float x1, float y1) + { + int patternTotal, i, offset; + float dx, dy, mag, dash_mag, rem, lx1, ly1; + float[] measured; + boolean which; + + /* Compute the total length of this pattern. */ + patternTotal = 0; + for (i = 0; i < gc.dashes.length; ++i) + patternTotal += gc.dashes[i]; + if ((gc.dashes.length & 1) != 0) + patternTotal += patternTotal; + + /* Subtract as much of the offset as does not contribute to the + phase at the first pixel of the line. */ + offset = gc.dash_offset % patternTotal; + + /* Set I to the first dash that ought to be drawn and WHICH to its + phase. */ + i = 0; + which = true; + while (offset >= gc.dashes[i]) + { + offset -= gc.dashes[i++]; + if (i >= gc.dashes.length) + i = 0; + which = !which; + } + + /* Compute the length of the first visible segment. */ + dash_mag = gc.dashes[i] - offset; + + /* Compute the slope of the line. */ + dx = x1 - x0; + dy = y1 - y0; + measured = measureLine (dx, dy); + dx = measured[0]; + dy = measured[1]; + rem = mag = measured[2]; + lx1 = x0; + ly1 = y0; + + while (rem > 0f) + { + dash_mag = Math.min (dash_mag, rem); + rem -= dash_mag; + + /* End of this segment. */ + x1 = (mag - rem) * dx + x0; + y1 = (mag - rem) * dy + y0; + + if (which) + canvas.drawLine (lx1, ly1, x1, y1, paint); + which = !which; + + /* Start of the next segment. */ + lx1 = x1; + ly1 = y1; + i++; + if (i >= gc.dashes.length) + i = 0; + dash_mag = gc.dashes[i]; + } + } + public static void perform (EmacsDrawable drawable, EmacsGC gc, int x, int y, int x2, int y2) @@ -52,22 +143,14 @@ public final class EmacsDrawLine if (canvas == null) return; - paint.setStyle (Paint.Style.FILL); - - /* Since drawLine has PostScript style behavior, adjust the - coordinates appropriately. - - The left most pixel of a straight line is always partially - filled. Patch it in manually. */ - if (gc.clip_mask == null) { - canvas.drawLine ((float) x + 0.5f, (float) y + 0.5f, - (float) x2 + 0.5f, (float) y2 + 0.5f, - paint); - - if (x2 > x) - canvas.drawRect (new Rect (x, y, x + 1, y + 1), paint); + if (gc.line_style != EmacsGC.GC_LINE_ON_OFF_DASH) + canvas.drawLine ((float) x, (float) y, (float) x2, (float) y2, + paint); + else + polyDashPattern (gc, canvas, paint, (float) x, (float) y, + (float) x2, (float) y2); } /* DrawLine with clip mask not implemented; it is not used by diff --git a/java/org/gnu/emacs/EmacsDrawRectangle.java b/java/org/gnu/emacs/EmacsDrawRectangle.java index a8f68c6530a..ea0f1c28106 100644 --- a/java/org/gnu/emacs/EmacsDrawRectangle.java +++ b/java/org/gnu/emacs/EmacsDrawRectangle.java @@ -22,13 +22,23 @@ package org.gnu.emacs; import android.graphics.Bitmap; import android.graphics.Canvas; import android.graphics.Paint; +import android.graphics.PorterDuff.Mode; +import android.graphics.PorterDuffXfermode; import android.graphics.Rect; import android.graphics.RectF; +import android.graphics.Xfermode; import android.util.Log; public final class EmacsDrawRectangle { + private static final Xfermode srcInAlu; + + static + { + srcInAlu = new PorterDuffXfermode (Mode.SRC_IN); + }; + public static void perform (EmacsDrawable drawable, EmacsGC gc, int x, int y, int width, int height) @@ -40,8 +50,10 @@ public final class EmacsDrawRectangle Canvas canvas; Bitmap clipBitmap; - /* TODO implement stippling. */ - if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED) + /* TODO implement stippling for this request. */ + if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED + /* And GC_INVERT also. */ + || gc.fill_style == EmacsGC.GC_INVERT) return; canvas = drawable.lockCanvas (gc); @@ -52,6 +64,9 @@ public final class EmacsDrawRectangle paint = gc.gcPaint; paint.setStyle (Paint.Style.STROKE); + /* This graphics request, in contrast to X, does not presently + respect the GC's line style. */ + if (gc.clip_mask == null) /* Use canvas.drawRect with a RectF. That seems to reliably get PostScript behavior. */ @@ -100,7 +115,7 @@ public final class EmacsDrawRectangle /* Set the transfer mode to SRC_IN to preserve only the parts of the source that overlap with the mask. */ maskPaint = new Paint (); - maskPaint.setXfermode (EmacsGC.srcInAlu); + maskPaint.setXfermode (srcInAlu); maskPaint.setStyle (Paint.Style.STROKE); /* Draw the source. */ diff --git a/java/org/gnu/emacs/EmacsFillRectangle.java b/java/org/gnu/emacs/EmacsFillRectangle.java index ca87c06c014..7642deed7c3 100644 --- a/java/org/gnu/emacs/EmacsFillRectangle.java +++ b/java/org/gnu/emacs/EmacsFillRectangle.java @@ -21,6 +21,8 @@ package org.gnu.emacs; import android.graphics.Bitmap; import android.graphics.Canvas; +import android.graphics.ColorFilter; +import android.graphics.ColorMatrixColorFilter; import android.graphics.Paint; import android.graphics.Rect; @@ -28,89 +30,62 @@ import android.util.Log; public final class EmacsFillRectangle { + /* Color filter that inverts colors from the source. */ + private static final ColorFilter invertFilter; + + static + { + invertFilter = new ColorMatrixColorFilter (new float[] { + -1f, 0f, 0f, 0f, 255f, + 0f, -1f, 0f, 0f, 255f, + 0f, 0f, -1f, 0f, 255f, + 0f, 0f, 0f, 1f, 0f, + }); + }; + public static void perform (EmacsDrawable drawable, EmacsGC gc, int x, int y, int width, int height) { - Paint maskPaint, paint; - Canvas maskCanvas; - Bitmap maskBitmap; + Paint paint; Rect rect; - Rect maskRect, dstRect; Canvas canvas; - Bitmap clipBitmap; - - /* TODO implement stippling. */ - if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED) - return; + Bitmap invertBitmap; canvas = drawable.lockCanvas (gc); - if (canvas == null) + /* Clip masks are not respected or implemented when specified with + this request. */ + if (canvas == null || gc.clip_mask != null) return; - paint = gc.gcPaint; rect = new Rect (x, y, x + width, y + height); - paint.setStyle (Paint.Style.FILL); + if (gc.function != EmacsGC.GC_INVERT) + { + paint = gc.gcPaint; + paint.setStyle (Paint.Style.FILL); - if (gc.clip_mask == null) - canvas.drawRect (rect, paint); + if (gc.fill_style != EmacsGC.GC_FILL_OPAQUE_STIPPLED) + canvas.drawRect (rect, paint); + else + gc.blitOpaqueStipple (canvas, rect); + } else { - /* Drawing with a clip mask involves calculating the - intersection of the clip mask with the dst rect, and - extrapolating the corresponding part of the src rect. */ - - clipBitmap = gc.clip_mask.bitmap; - dstRect = new Rect (x, y, x + width, y + height); - maskRect = new Rect (gc.clip_x_origin, - gc.clip_y_origin, - (gc.clip_x_origin - + clipBitmap.getWidth ()), - (gc.clip_y_origin - + clipBitmap.getHeight ())); - - if (!maskRect.setIntersect (dstRect, maskRect)) - /* There is no intersection between the clip mask and the - dest rect. */ - return; - - /* Finally, create a temporary bitmap that is the size of - maskRect. */ - - maskBitmap - = Bitmap.createBitmap (maskRect.width (), maskRect.height (), - Bitmap.Config.ARGB_8888); - - /* Draw the mask onto the maskBitmap. */ - maskCanvas = new Canvas (maskBitmap); - maskRect.offset (-gc.clip_x_origin, - -gc.clip_y_origin); - maskCanvas.drawBitmap (gc.clip_mask.bitmap, - maskRect, new Rect (0, 0, - maskRect.width (), - maskRect.height ()), - paint); - maskRect.offset (gc.clip_x_origin, - gc.clip_y_origin); - - /* Set the transfer mode to SRC_IN to preserve only the parts - of the source that overlap with the mask. */ - maskPaint = new Paint (); - maskPaint.setXfermode (EmacsGC.srcInAlu); - - /* Draw the source. */ - maskCanvas.drawRect (maskRect, maskPaint); - - /* Finally, draw the mask bitmap to the destination. */ - paint.setXfermode (null); - canvas.drawBitmap (maskBitmap, null, maskRect, paint); - - /* Recycle this unused bitmap. */ - maskBitmap.recycle (); + paint = new Paint (); + + /* Simply invert the destination, which is only implemented for + this request. As Android doesn't permit copying a bitmap to + itself, a copy of the source must be procured beforehand. */ + invertBitmap = Bitmap.createBitmap (drawable.getBitmap (), + x, y, width, height); + paint.setColorFilter (invertFilter); + canvas.drawBitmap (invertBitmap, null, rect, paint); + paint.setColorFilter (null); + invertBitmap.recycle (); } drawable.damageRect (rect); } -} +}; diff --git a/java/org/gnu/emacs/EmacsGC.java b/java/org/gnu/emacs/EmacsGC.java index e45f0666fe2..d400c23e067 100644 --- a/java/org/gnu/emacs/EmacsGC.java +++ b/java/org/gnu/emacs/EmacsGC.java @@ -22,31 +22,42 @@ package org.gnu.emacs; import android.graphics.Rect; import android.graphics.Paint; +import android.graphics.Bitmap; +import android.graphics.Canvas; +import android.graphics.ColorFilter; import android.graphics.PorterDuff.Mode; -import android.graphics.PorterDuffXfermode; -import android.graphics.Xfermode; +import android.graphics.PorterDuffColorFilter; +import android.graphics.Shader.TileMode; + +import android.os.Build; /* X like graphics context structures. Keep the enums in synch with androidgui.h! */ public final class EmacsGC extends EmacsHandleObject { - public static final int GC_COPY = 0; - public static final int GC_XOR = 1; + public static final int GC_COPY = 0; + public static final int GC_INVERT = 1; public static final int GC_FILL_SOLID = 0; public static final int GC_FILL_OPAQUE_STIPPLED = 1; - public static final Xfermode xorAlu, srcInAlu; + public static final int GC_LINE_SOLID = 0; + public static final int GC_LINE_ON_OFF_DASH = 1; public int function, fill_style; public int foreground, background; public int clip_x_origin, clip_y_origin; public int ts_origin_x, ts_origin_y; + public int line_style, line_width; + public int dashes[], dash_offset; public Rect clip_rects[], real_clip_rects[]; public EmacsPixmap clip_mask, stipple; public Paint gcPaint; + /* Drawable object for rendering the stiple bitmap. */ + public EmacsTileObject tileObject; + /* ID incremented every time the clipping rectangles of any GC changes. */ private static long clip_serial; @@ -55,28 +66,26 @@ public final class EmacsGC extends EmacsHandleObject rectangles changed. 0 if there are no clip rectangles. */ public long clipRectID; - static - { - xorAlu = new PorterDuffXfermode (Mode.XOR); - srcInAlu = new PorterDuffXfermode (Mode.SRC_IN); - } - /* The following fields are only set on immutable GCs. */ public - EmacsGC (short handle) + EmacsGC () { /* For historical reasons the C code has an extra layer of indirection above this GC handle. struct android_gc is the GC used by Emacs code, while android_gcontext is the type of the handle. */ - super (handle); + super (); fill_style = GC_FILL_SOLID; function = GC_COPY; foreground = 0; background = 0xffffff; gcPaint = new Paint (); + + /* Android S and above enable anti-aliasing unless explicitly told + otherwise. */ + gcPaint.setAntiAlias (false); } /* Mark this GC as dirty. Apply parameters to the paint and @@ -86,6 +95,7 @@ public final class EmacsGC extends EmacsHandleObject markDirty (boolean clipRectsChanged) { int i; + Bitmap stippleBitmap; if (clipRectsChanged) { @@ -106,16 +116,83 @@ public final class EmacsGC extends EmacsHandleObject clipRectID = ++clip_serial; } - gcPaint.setStrokeWidth (1f); + /* A line_width of 0 is equivalent to that of 1. */ + gcPaint.setStrokeWidth (line_width < 1 ? 1 : line_width); gcPaint.setColor (foreground | 0xff000000); - gcPaint.setXfermode (function == GC_XOR - ? xorAlu : srcInAlu); + + /* Update the stipple object with the new stipple bitmap, or delete + it if the stipple has been cleared on systems too old to support + modifying such objects. */ + + if (stipple != null) + { + stippleBitmap = stipple.getBitmap (); + + /* Allocate a new tile object if none is already present or it + cannot be reconfigured. */ + if (tileObject == null) + { + tileObject = new EmacsTileObject (stippleBitmap); + tileObject.setTileModeXY (TileMode.REPEAT, TileMode.REPEAT); + } + else + /* Otherwise, update the existing tile object with the new + bitmap. */ + tileObject.setBitmap (stippleBitmap); + } + else if (tileObject != null) + tileObject.setBitmap (null); } - public void - resetXfermode () + /* Prepare the tile object to draw a stippled image onto a section of + a drawable defined by RECT. It is an error to call this function + unless the `stipple' field of the GContext is set. */ + + private void + prepareStipple (Rect rect) + { + int sx, sy; /* Stipple origin. */ + int bw, bh; /* Stipple size. */ + Bitmap bitmap; + Rect boundsRect; + + /* Retrieve the dimensions of the stipple bitmap, which doubles as + the unit of advance for this stipple. */ + bitmap = tileObject.getBitmap (); + bw = bitmap.getWidth (); + bh = bitmap.getHeight (); + + /* Align the lower left corner of the bounds rectangle to the + initial position of the stipple. */ + sx = (rect.left % bw) * -1 + (-ts_origin_x % bw) * -1; + sy = (rect.top % bh) * -1 + (-ts_origin_y % bh) * -1; + boundsRect = new Rect (rect.left + sx, rect.top + sy, + rect.right, rect.bottom); + tileObject.setBounds (boundsRect); + } + + /* Fill the rectangle BOUNDS in the provided CANVAS with the stipple + pattern defined for this GContext, in the foreground color where + the pattern is on, and in the background color where off. */ + + protected void + blitOpaqueStipple (Canvas canvas, Rect rect) { - gcPaint.setXfermode (function == GC_XOR - ? xorAlu : srcInAlu); + ColorFilter filter; + + prepareStipple (rect); + filter = new PorterDuffColorFilter (foreground | 0xff000000, + Mode.SRC_IN); + tileObject.setColorFilter (filter); + + canvas.save (); + canvas.clipRect (rect); + + tileObject.draw (canvas); + filter = new PorterDuffColorFilter (background | 0xff000000, + Mode.SRC_OUT); + tileObject.setColorFilter (filter); + tileObject.draw (canvas); + canvas.restore (); } }; diff --git a/java/org/gnu/emacs/EmacsHandleObject.java b/java/org/gnu/emacs/EmacsHandleObject.java index 8534f08519c..cbd579bac5b 100644 --- a/java/org/gnu/emacs/EmacsHandleObject.java +++ b/java/org/gnu/emacs/EmacsHandleObject.java @@ -33,14 +33,9 @@ public abstract class EmacsHandleObject /* Whether or not this handle has been destroyed. */ volatile boolean destroyed; - /* The handle associated with this object. */ - public short handle; - - public - EmacsHandleObject (short handle) - { - this.handle = handle; - } + /* The handle associated with this object, set in + android_globalize_reference. */ + public long handle; public void destroyHandle () throws IllegalStateException diff --git a/java/org/gnu/emacs/EmacsInputConnection.java b/java/org/gnu/emacs/EmacsInputConnection.java index 054eca66cf3..5b409fa1f57 100644 --- a/java/org/gnu/emacs/EmacsInputConnection.java +++ b/java/org/gnu/emacs/EmacsInputConnection.java @@ -48,7 +48,7 @@ public final class EmacsInputConnection implements InputConnection private EmacsView view; /* The handle ID associated with that view's window. */ - private short windowHandle; + private long windowHandle; /* Number of batch edits currently underway. Used to avoid synchronizing with the Emacs thread after each diff --git a/java/org/gnu/emacs/EmacsMultitaskActivity.java b/java/org/gnu/emacs/EmacsMultitaskActivity.java index 7229e34496e..10963ecfd3f 100644 --- a/java/org/gnu/emacs/EmacsMultitaskActivity.java +++ b/java/org/gnu/emacs/EmacsMultitaskActivity.java @@ -19,11 +19,39 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ package org.gnu.emacs; -/* This class only exists because EmacsActivity is already defined as - an activity, and the system wants a new class in order to define a - new activity. */ +import android.content.Intent; + +import android.os.Bundle; + +/* In large measure, this class only exists because EmacsActivity is + already defined as an activity, and the system requires that every + new activity be defined by a new class. */ public final class EmacsMultitaskActivity extends EmacsActivity { - -} + /* Token provided by the creator. */ + private long activityToken; + + @Override + public final void + onCreate (Bundle savedInstanceState) + { + Intent intent; + String token; + + intent = getIntent (); + token = EmacsWindowManager.ACTIVITY_TOKEN; + + if (intent != null) + activityToken = intent.getLongExtra (token, -2); + + super.onCreate (savedInstanceState); + } + + @Override + public final long + getAttachmentToken () + { + return activityToken; + } +}; diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index 654e94b1a7d..b2764edad10 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -108,92 +108,92 @@ public final class EmacsNative /* Send an ANDROID_CONFIGURE_NOTIFY event. The values of all the functions below are the serials of the events sent. */ - public static native long sendConfigureNotify (short window, long time, + public static native long sendConfigureNotify (long window, long time, int x, int y, int width, int height); /* Send an ANDROID_KEY_PRESS event. */ - public static native long sendKeyPress (short window, long time, int state, + public static native long sendKeyPress (long window, long time, int state, int keyCode, int unicodeChar); /* Send an ANDROID_KEY_RELEASE event. */ - public static native long sendKeyRelease (short window, long time, int state, + public static native long sendKeyRelease (long window, long time, int state, int keyCode, int unicodeChar); /* Send an ANDROID_FOCUS_IN event. */ - public static native long sendFocusIn (short window, long time); + public static native long sendFocusIn (long window, long time); /* Send an ANDROID_FOCUS_OUT event. */ - public static native long sendFocusOut (short window, long time); + public static native long sendFocusOut (long window, long time); /* Send an ANDROID_WINDOW_ACTION event. */ - public static native long sendWindowAction (short window, int action); + public static native long sendWindowAction (long window, int action); /* Send an ANDROID_ENTER_NOTIFY event. */ - public static native long sendEnterNotify (short window, int x, int y, + public static native long sendEnterNotify (long window, int x, int y, long time); /* Send an ANDROID_LEAVE_NOTIFY event. */ - public static native long sendLeaveNotify (short window, int x, int y, + public static native long sendLeaveNotify (long window, int x, int y, long time); /* Send an ANDROID_MOTION_NOTIFY event. */ - public static native long sendMotionNotify (short window, int x, int y, + public static native long sendMotionNotify (long window, int x, int y, long time); /* Send an ANDROID_BUTTON_PRESS event. */ - public static native long sendButtonPress (short window, int x, int y, + public static native long sendButtonPress (long window, int x, int y, long time, int state, int button); /* Send an ANDROID_BUTTON_RELEASE event. */ - public static native long sendButtonRelease (short window, int x, int y, + public static native long sendButtonRelease (long window, int x, int y, long time, int state, int button); /* Send an ANDROID_TOUCH_DOWN event. */ - public static native long sendTouchDown (short window, int x, int y, + public static native long sendTouchDown (long window, int x, int y, long time, int pointerID, int flags); /* Send an ANDROID_TOUCH_UP event. */ - public static native long sendTouchUp (short window, int x, int y, + public static native long sendTouchUp (long window, int x, int y, long time, int pointerID, int flags); /* Send an ANDROID_TOUCH_MOVE event. */ - public static native long sendTouchMove (short window, int x, int y, + public static native long sendTouchMove (long window, int x, int y, long time, int pointerID, int flags); /* Send an ANDROID_WHEEL event. */ - public static native long sendWheel (short window, int x, int y, + public static native long sendWheel (long window, int x, int y, long time, int state, float xDelta, float yDelta); /* Send an ANDROID_ICONIFIED event. */ - public static native long sendIconified (short window); + public static native long sendIconified (long window); /* Send an ANDROID_DEICONIFIED event. */ - public static native long sendDeiconified (short window); + public static native long sendDeiconified (long window); /* Send an ANDROID_CONTEXT_MENU event. */ - public static native long sendContextMenu (short window, int menuEventID, + public static native long sendContextMenu (long window, int menuEventID, int menuEventSerial); /* Send an ANDROID_EXPOSE event. */ - public static native long sendExpose (short window, int x, int y, + public static native long sendExpose (long window, int x, int y, int width, int height); /* Send an ANDROID_DND_DRAG event. */ - public static native long sendDndDrag (short window, int x, int y); + public static native long sendDndDrag (long window, int x, int y); /* Send an ANDROID_DND_URI event. */ - public static native long sendDndUri (short window, int x, int y, + public static native long sendDndUri (long window, int x, int y, String text); /* Send an ANDROID_DND_TEXT event. */ - public static native long sendDndText (short window, int x, int y, + public static native long sendDndText (long window, int x, int y, String text); /* Send an ANDROID_NOTIFICATION_CANCELED event. */ @@ -228,6 +228,10 @@ public final class EmacsNative be prevented from reaching the system input method. */ public static native boolean shouldForwardCtrlSpace (); + /* Return the keycode repeated activation of which should signal + quit. */ + public static native int getQuitKeycode (); + /* Initialize the current thread, by blocking signals that do not interest it. */ public static native void setupSystemThread (); @@ -237,48 +241,48 @@ public final class EmacsNative /* Input connection functions. These mostly correspond to their counterparts in Android's InputConnection. */ - public static native void beginBatchEdit (short window); - public static native void endBatchEdit (short window); - public static native void commitCompletion (short window, String text, + public static native void beginBatchEdit (long window); + public static native void endBatchEdit (long window); + public static native void commitCompletion (long window, String text, int position); - public static native void commitText (short window, String text, + public static native void commitText (long window, String text, int position); - public static native void deleteSurroundingText (short window, + public static native void deleteSurroundingText (long window, int leftLength, int rightLength); - public static native void finishComposingText (short window); - public static native void replaceText (short window, int start, int end, + public static native void finishComposingText (long window); + public static native void replaceText (long window, int start, int end, String text, int newCursorPosition, TextAttribute attributes); - public static native String getSelectedText (short window, int flags); - public static native String getTextAfterCursor (short window, int length, + public static native String getSelectedText (long window, int flags); + public static native String getTextAfterCursor (long window, int length, int flags); - public static native String getTextBeforeCursor (short window, int length, + public static native String getTextBeforeCursor (long window, int length, int flags); - public static native void setComposingText (short window, String text, + public static native void setComposingText (long window, String text, int newCursorPosition); - public static native void setComposingRegion (short window, int start, + public static native void setComposingRegion (long window, int start, int end); - public static native void setSelection (short window, int start, int end); - public static native void performEditorAction (short window, + public static native void setSelection (long window, int start, int end); + public static native void performEditorAction (long window, int editorAction); - public static native void performContextMenuAction (short window, + public static native void performContextMenuAction (long window, int contextMenuAction); - public static native ExtractedText getExtractedText (short window, + public static native ExtractedText getExtractedText (long window, ExtractedTextRequest req, int flags); - public static native void requestSelectionUpdate (short window); - public static native void requestCursorUpdates (short window, int mode); - public static native void clearInputFlags (short window); - public static native SurroundingText getSurroundingText (short window, + public static native void requestSelectionUpdate (long window); + public static native void requestCursorUpdates (long window, int mode); + public static native void clearInputFlags (long window); + public static native SurroundingText getSurroundingText (long window, int left, int right, int flags); - public static native TextSnapshot takeSnapshot (short window); + public static native TextSnapshot takeSnapshot (long window); /* Return the current value of the selection, or -1 upon failure. */ - public static native int[] getSelection (short window); + public static native int[] getSelection (long window); /* Graphics functions used as replacements for potentially buggy @@ -321,39 +325,35 @@ public final class EmacsNative static { - /* Older versions of Android cannot link correctly with shared - libraries that link with other shared libraries built along - Emacs unless all requisite shared libraries are explicitly - loaded from Java. - - Every time you add a new shared library dependency to Emacs, - please add it here as well. */ - - libraryDeps = new String[] { "c++_shared", "gnustl_shared", - "stlport_shared", "gabi++_shared", - "png_emacs", "selinux_emacs", - "crypto_emacs", "pcre_emacs", - "packagelistparser_emacs", - "gnutls_emacs", "gmp_emacs", - "nettle_emacs", "p11-kit_emacs", - "tasn1_emacs", "hogweed_emacs", - "jansson_emacs", "jpeg_emacs", - "tiff_emacs", "xml2_emacs", - "icuuc_emacs", "harfbuzz_emacs", - "tree-sitter_emacs", }; + /* A library search path misconfiguration prevents older versions of + Android from successfully loading application shared libraries + unless all requisite shared libraries provided by the application + are explicitly loaded from Java. The build process arranges that + EmacsConfig.EMACS_SHARED_LIBRARIES hold the names of each of + these libraries in the correct order, so load them now. */ + + libraryDeps = EmacsConfig.EMACS_SHARED_LIBRARIES; for (String dependency : libraryDeps) { - try - { - System.loadLibrary (dependency); - } - catch (UnsatisfiedLinkError exception) - { - /* Ignore this exception. */ - } + /* Remove the "lib" prefix, if any. */ + if (dependency.startsWith ("lib")) + dependency = dependency.substring (3); + + /* If this library is provided by the operating system, don't + link to it. */ + if (dependency.equals ("z") + || dependency.equals ("c") + || dependency.equals ("m") + || dependency.equals ("dl") + || dependency.equals ("log") + || dependency.equals ("android")) + continue; + + System.loadLibrary (dependency); } + /* At this point, it should be alright to load Emacs. */ System.loadLibrary ("emacs"); }; }; diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java index 327a53bc417..28e1e261821 100644 --- a/java/org/gnu/emacs/EmacsOpenActivity.java +++ b/java/org/gnu/emacs/EmacsOpenActivity.java @@ -19,29 +19,23 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ package org.gnu.emacs; -/* This class makes the Emacs server work reasonably on Android. +/* Opening external documents on Android. - There is no way to make the Unix socket publicly available on - Android. + This activity is registered as an application capable of opening text + files and files in several other formats that Emacs understands, and + assumes responsibility for deriving file names from the files + provided to `onCreate', potentially copying them to temporary + directories in the process, and invoking `emacsclient' with suitable + arguments to open the same. In this respect, it fills the role of + `etc/emacs.desktop' on XDG systems. - Instead, this activity tries to connect to the Emacs server, to - make it open files the system asks Emacs to open, and to emulate - some reasonable behavior when Emacs has not yet started. + It is also registered as a handler for mailto URIs, in which capacity + it constructs invocations of `emacsclient' so as to start + `message-mailto' with their contents and attachments, much like + `etc/emacs-mail.desktop'. - First, Emacs registers itself as an application that can open text - and image files. - - Then, when the user is asked to open a file and selects ``Emacs'' - as the application that will open the file, the system pops up a - window, this activity, and calls the `onCreate' function. - - `onCreate' then tries very to find the file name of the file that - was selected, and give it to emacsclient. - - If emacsclient successfully opens the file, then this activity - starts EmacsActivity (to bring it on to the screen); otherwise, it - displays the output of emacsclient or any error message that occurs - and exits. */ + As with all other activities, it is registered in the package + manifest file. */ import android.app.AlertDialog; import android.app.Activity; @@ -76,11 +70,6 @@ public final class EmacsOpenActivity extends Activity { private static final String TAG = "EmacsOpenActivity"; - /* The name of any file that should be opened as EmacsThread starts - Emacs. This is never cleared, even if EmacsOpenActivity is - started a second time, as EmacsThread only starts once. */ - public static String fileToOpen; - /* Any currently focused EmacsOpenActivity. Used to show pop ups while the activity is active and Emacs doesn't have permission to display over other programs. */ @@ -628,11 +617,12 @@ public final class EmacsOpenActivity extends Activity if (scheme.equals ("content") /* Retrieving the native file descriptor of a - ParcelFileDescriptor requires Honeycomb, and + ParcelFileDescriptor requires Honeycomb MR1, and proceeding without this capability is pointless on systems before KitKat, since Emacs doesn't support opening content files on those. */ - && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) + && (Build.VERSION.SDK_INT + >= Build.VERSION_CODES.HONEYCOMB_MR1)) { /* This is one of the annoying Android ``content'' URIs. Most of the time, there is actually an @@ -702,9 +692,10 @@ public final class EmacsOpenActivity extends Activity if (EmacsService.SERVICE == null) { - fileToOpen = fileName; intent = new Intent (EmacsOpenActivity.this, EmacsActivity.class); + intent.putExtra (EmacsActivity.EXTRA_STARTUP_ARGUMENTS, + new String [] { fileName, }); finish (); startActivity (intent); return; diff --git a/java/org/gnu/emacs/EmacsPixmap.java b/java/org/gnu/emacs/EmacsPixmap.java index c621e2de3c5..bd4e085994e 100644 --- a/java/org/gnu/emacs/EmacsPixmap.java +++ b/java/org/gnu/emacs/EmacsPixmap.java @@ -51,9 +51,9 @@ public final class EmacsPixmap extends EmacsHandleObject private long gcClipRectID; public - EmacsPixmap (short handle, int width, int height, int depth) + EmacsPixmap (int width, int height, int depth) { - super (handle); + super (); if (depth != 1 && depth != 24) throw new IllegalArgumentException ("Invalid depth specified" diff --git a/java/org/gnu/emacs/EmacsPreferencesActivity.java b/java/org/gnu/emacs/EmacsPreferencesActivity.java index 766e2e11d46..a3edd6388b4 100644 --- a/java/org/gnu/emacs/EmacsPreferencesActivity.java +++ b/java/org/gnu/emacs/EmacsPreferencesActivity.java @@ -57,7 +57,8 @@ public class EmacsPreferencesActivity extends PreferenceActivity intent = new Intent (this, EmacsActivity.class); intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK | Intent.FLAG_ACTIVITY_CLEAR_TASK); - intent.putExtra ("org.gnu.emacs.STARTUP_ARGUMENT", "--quick"); + intent.putExtra (EmacsActivity.EXTRA_STARTUP_ARGUMENTS, + new String[] {"--quick", }); startActivity (intent); System.exit (0); } @@ -74,7 +75,8 @@ public class EmacsPreferencesActivity extends PreferenceActivity intent = new Intent (this, EmacsActivity.class); intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK | Intent.FLAG_ACTIVITY_CLEAR_TASK); - intent.putExtra ("org.gnu.emacs.STARTUP_ARGUMENT", "--debug-init"); + intent.putExtra (EmacsActivity.EXTRA_STARTUP_ARGUMENTS, + new String[] {"--debug-init", }); startActivity (intent); System.exit (0); } diff --git a/java/org/gnu/emacs/EmacsSafThread.java b/java/org/gnu/emacs/EmacsSafThread.java index 14c3f222833..ee8c2e7e0c3 100644 --- a/java/org/gnu/emacs/EmacsSafThread.java +++ b/java/org/gnu/emacs/EmacsSafThread.java @@ -1623,10 +1623,10 @@ public final class EmacsSafThread extends HandlerThread mode is merely w. This may be ascribed to a mix-up in Android's documentation - regardin DocumentsProvider: the `openDocument' function is only - documented to accept r or rw, whereas the default - implementation of the `openFile' function (which documents rwt) - delegates to `openDocument'. */ + regarding DocumentsProvider: the `openDocument' function is only + documented to accept r or rw, whereas the default implementation + of the `openFile' function (which documents rwt) delegates to + `openDocument'. */ if (read && write && truncate && fileDescriptor != null && !EmacsNative.ftruncate (fileDescriptor.getFd ())) diff --git a/java/org/gnu/emacs/EmacsSdk11Clipboard.java b/java/org/gnu/emacs/EmacsSdk11Clipboard.java index 850bb6c8deb..dfc714476ec 100644 --- a/java/org/gnu/emacs/EmacsSdk11Clipboard.java +++ b/java/org/gnu/emacs/EmacsSdk11Clipboard.java @@ -172,12 +172,12 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard clipboard, or NULL if there are none. */ @Override - public byte[][] + public String[] getClipboardTargets () { ClipData clip; ClipDescription description; - byte[][] typeArray; + String[] typeArray; int i; /* N.B. that Android calls the clipboard the ``primary clip''; it @@ -189,17 +189,10 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard description = clip.getDescription (); i = description.getMimeTypeCount (); - typeArray = new byte[i][i]; + typeArray = new String[i]; - try - { - for (i = 0; i < description.getMimeTypeCount (); ++i) - typeArray[i] = description.getMimeType (i).getBytes ("UTF-8"); - } - catch (UnsupportedEncodingException exception) - { - return null; - } + for (i = 0; i < description.getMimeTypeCount (); ++i) + typeArray[i] = description.getMimeType (i); return typeArray; } @@ -207,8 +200,9 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard /* Return the clipboard data for the given target, or NULL if it does not exist. - Value is normally an array of three longs: the file descriptor, - the start offset of the data, and its length; length may be + Value is normally an asset file descriptor, which in turn holds + three important values: the file descriptor, the start offset of + the data, and its length; length may be AssetFileDescriptor.UNKNOWN_LENGTH, meaning that the data extends from that offset to the end of the file. @@ -217,36 +211,23 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard solely of a URI. */ @Override - public long[] - getClipboardData (byte[] target) + public AssetFileDescriptor + getClipboardData (String target) { ClipData data; String mimeType; - int fd; AssetFileDescriptor assetFd; Uri uri; - long[] value; - - /* Decode the target given by Emacs. */ - try - { - mimeType = new String (target, "UTF-8"); - } - catch (UnsupportedEncodingException exception) - { - return null; - } /* Now obtain the clipboard data and the data corresponding to that MIME type. */ + mimeType = target; data = manager.getPrimaryClip (); if (data == null || data.getItemCount () < 1) return null; - fd = -1; - try { uri = data.getItemAt (0).getUri (); @@ -257,52 +238,15 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard /* Now open the file descriptor. */ assetFd = resolver.openTypedAssetFileDescriptor (uri, mimeType, null); - - /* Duplicate the file descriptor. */ - fd = assetFd.getParcelFileDescriptor ().getFd (); - fd = EmacsNative.dup (fd); - - /* Return the relevant information. */ - value = new long[] { fd, assetFd.getStartOffset (), - assetFd.getLength (), }; - - /* Close the original offset. */ - assetFd.close (); + return assetFd; } catch (SecurityException e) { - /* Guarantee a file descriptor duplicated or detached is - ultimately closed if an error arises. */ - - if (fd != -1) - EmacsNative.close (fd); - return null; } catch (FileNotFoundException e) { - /* Guarantee a file descriptor duplicated or detached is - ultimately closed if an error arises. */ - - if (fd != -1) - EmacsNative.close (fd); - return null; } - catch (IOException e) - { - /* Guarantee a file descriptor duplicated or detached is - ultimately closed if an error arises. */ - - if (fd != -1) - EmacsNative.close (fd); - - return null; - } - - /* Don't return value if the file descriptor couldn't be - created. */ - - return fd != -1 ? value : null; } }; diff --git a/java/org/gnu/emacs/EmacsSdk8Clipboard.java b/java/org/gnu/emacs/EmacsSdk8Clipboard.java index 418f55c12c1..344ec6f7997 100644 --- a/java/org/gnu/emacs/EmacsSdk8Clipboard.java +++ b/java/org/gnu/emacs/EmacsSdk8Clipboard.java @@ -25,6 +25,8 @@ package org.gnu.emacs; import android.text.*; import android.content.Context; +import android.content.res.AssetFileDescriptor; + import android.util.Log; import java.io.UnsupportedEncodingException; @@ -120,7 +122,7 @@ public final class EmacsSdk8Clipboard extends EmacsClipboard clipboard, or NULL if there are none. */ @Override - public byte[][] + public String[] getClipboardTargets () { return null; @@ -129,9 +131,10 @@ public final class EmacsSdk8Clipboard extends EmacsClipboard /* Return the clipboard data for the given target, or NULL if it does not exist. - Value is normally an array of three longs: the file descriptor, - the start offset of the data, and its length; length may be - AssetFileDescriptor.UNKOWN_LENGTH, meaning that the data extends + Value is normally an asset file descriptor, which in turn holds + three important values: the file descriptor, the start offset of + the data, and its length; length may be + AssetFileDescriptor.UNKNOWN_LENGTH, meaning that the data extends from that offset to the end of the file. Do not use this function to open text targets; use `getClipboard' @@ -139,8 +142,8 @@ public final class EmacsSdk8Clipboard extends EmacsClipboard solely of a URI. */ @Override - public long[] - getClipboardData (byte[] target) + public AssetFileDescriptor + getClipboardData (String target) { return null; } diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 446cd26a3dd..2dcaad16e50 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -25,6 +25,7 @@ import java.io.IOException; import java.io.UnsupportedEncodingException; import java.util.ArrayList; +import java.util.Arrays; import java.util.HashSet; import java.util.List; @@ -64,21 +65,23 @@ import android.content.pm.PackageManager; import android.content.res.AssetManager; import android.content.res.Configuration; +import android.content.res.Resources; import android.hardware.input.InputManager; import android.net.Uri; import android.os.BatteryManager; +import android.os.Binder; import android.os.Build; import android.os.Environment; -import android.os.Looper; -import android.os.IBinder; import android.os.Handler; +import android.os.IBinder; +import android.os.Looper; import android.os.ParcelFileDescriptor; +import android.os.VibrationEffect; import android.os.Vibrator; import android.os.VibratorManager; -import android.os.VibrationEffect; import android.provider.DocumentsContract; import android.provider.DocumentsContract.Document; @@ -100,9 +103,9 @@ public final class EmacsService extends Service /* The started Emacs service object. */ public static EmacsService SERVICE; - /* If non-NULL, an extra argument to pass to + /* If non-NULL, an array of extra arguments to pass to `android_emacs_init'. */ - public static String extraStartupArgument; + public static String[] extraStartupArguments; /* The thread running Emacs C code. */ private EmacsThread thread; @@ -145,6 +148,9 @@ public final class EmacsService extends Service thread. */ private Thread mainThread; + /* "Resources" object required by GContext bookkeeping. */ + public static Resources resources; + static { servicingQuery = new AtomicInteger (); @@ -182,11 +188,11 @@ public final class EmacsService extends Service manager = (NotificationManager) tem; infoBlurb = ("This notification is displayed to keep Emacs" + " running while it is in the background. You" - + " may disable it if you want;" + + " may disable it if you wish;" + " see (emacs)Android Environment."); channel = new NotificationChannel ("emacs", "Emacs Background Service", - NotificationManager.IMPORTANCE_DEFAULT); + NotificationManager.IMPORTANCE_LOW); manager.createNotificationChannel (channel); notification = (new Notification.Builder (this, "emacs") .setContentTitle ("Emacs") @@ -234,11 +240,14 @@ public final class EmacsService extends Service final double scaledDensity; double tempScaledDensity; + super.onCreate (); + SERVICE = this; + resources = getResources (); handler = new Handler (Looper.getMainLooper ()); manager = getAssets (); app_context = getApplicationContext (); - metrics = getResources ().getDisplayMetrics (); + metrics = resources.getDisplayMetrics (); pixelDensityX = metrics.xdpi; pixelDensityY = metrics.ydpi; tempScaledDensity = ((getScaledDensity (metrics) @@ -247,9 +256,9 @@ public final class EmacsService extends Service resolver = getContentResolver (); mainThread = Thread.currentThread (); - /* If the density used to compute the text size is lesser than - 160, there's likely a bug with display density computation. - Reset it to 160 in that case. + /* If the density used to compute the text size is smaller than 160, + there's likely a bug with display density computation. Reset it + to 160 in that case. Note that Android uses 160 ``dpi'' as the density where 1 point corresponds to 1 pixel, not 72 or 96 as used elsewhere. This @@ -262,6 +271,10 @@ public final class EmacsService extends Service the nested function below. */ scaledDensity = tempScaledDensity; + /* Remove all tasks from previous Emacs sessions but the task + created by the system at startup. */ + EmacsWindowManager.MANAGER.removeOldTasks (this); + try { /* Configure Emacs with the asset manager and other necessary @@ -277,7 +290,9 @@ public final class EmacsService extends Service Log.d (TAG, "Initializing Emacs, where filesDir = " + filesDir + ", libDir = " + libDir + ", and classPath = " + classPath - + "; fileToOpen = " + EmacsOpenActivity.fileToOpen + + "; args = " + (extraStartupArguments != null + ? Arrays.toString (extraStartupArguments) + : "(none)") + "; display density: " + pixelDensityX + " by " + pixelDensityY + " scaled to " + scaledDensity); @@ -294,9 +309,7 @@ public final class EmacsService extends Service classPath, EmacsService.this, Build.VERSION.SDK_INT); } - }, extraStartupArgument, - /* If any file needs to be opened, open it now. */ - EmacsOpenActivity.fileToOpen); + }, extraStartupArguments); thread.start (); } catch (IOException exception) @@ -387,6 +400,23 @@ public final class EmacsService extends Service EmacsService.<Void>syncRunnable (task); } + public void + getLocationInWindow (final EmacsView view, final int[] coordinates) + { + FutureTask<Void> task; + + task = new FutureTask<Void> (new Callable<Void> () { + public Void + call () + { + view.getLocationInWindow (coordinates); + return null; + } + }); + + EmacsService.<Void>syncRunnable (task); + } + public static void @@ -485,22 +515,22 @@ public final class EmacsService extends Service vibrator.vibrate (duration); } - public short[] + public long[] queryTree (EmacsWindow window) { - short[] array; + long[] array; List<EmacsWindow> windowList; int i; if (window == null) /* Just return all the windows without a parent. */ - windowList = EmacsWindowAttachmentManager.MANAGER.copyWindows (); + windowList = EmacsWindowManager.MANAGER.copyWindows (); else windowList = window.children; synchronized (windowList) { - array = new short[windowList.size () + 1]; + array = new long[windowList.size () + 1]; i = 1; array[0] = (window == null @@ -817,7 +847,7 @@ public final class EmacsService extends Service } public static int[] - viewGetSelection (short window) + viewGetSelection (long window) { int[] selection; @@ -938,11 +968,13 @@ public final class EmacsService extends Service string; make it writable if WRITABLE, and readable if READABLE. Truncate the file if TRUNCATE. - Value is the resulting file descriptor or -1 upon failure. */ + Value is the resulting file descriptor, -1, or an exception will be + raised. */ public int - openContentUri (byte[] bytes, boolean writable, boolean readable, + openContentUri (String uri, boolean writable, boolean readable, boolean truncate) + throws FileNotFoundException, IOException { String name, mode; ParcelFileDescriptor fd; @@ -961,39 +993,19 @@ public final class EmacsService extends Service if (truncate) mode += "t"; - /* Try to open an associated ParcelFileDescriptor. */ - - try - { - /* The usual file name encoding question rears its ugly head - again. */ - - name = new String (bytes, "UTF-8"); - fd = resolver.openFileDescriptor (Uri.parse (name), mode); + /* Try to open a corresponding ParcelFileDescriptor. Though + `fd.detachFd' is exclusive to Honeycomb and up, this function is + never called on systems older than KitKat, which is Emacs's + minimum requirement for access to /content/by-authority. */ - /* Use detachFd on newer versions of Android or plain old - dup. */ + fd = resolver.openFileDescriptor (Uri.parse (uri), mode); + if (fd == null) + return -1; - if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB_MR1) - { - i = fd.detachFd (); - fd.close (); + i = fd.detachFd (); + fd.close (); - return i; - } - else - { - i = EmacsNative.dup (fd.getFd ()); - fd.close (); - - return i; - } - } - catch (Exception exception) - { - exception.printStackTrace (); - return -1; - } + return i; } /* Return whether Emacs is directly permitted to access the @@ -1004,11 +1016,8 @@ public final class EmacsService extends Service public boolean checkContentUri (String name, boolean readable, boolean writable) { - String mode; - ParcelFileDescriptor fd; Uri uri; int rc, flags; - ParcelFileDescriptor descriptor; uri = Uri.parse (name); flags = 0; @@ -1019,47 +1028,21 @@ public final class EmacsService extends Service if (writable) flags |= Intent.FLAG_GRANT_WRITE_URI_PERMISSION; - rc = checkCallingUriPermission (uri, flags); - - if (rc == PackageManager.PERMISSION_GRANTED) - return true; - - /* In the event checkCallingUriPermission fails and only read - permissions are being verified, attempt to query the URI. This - enables ascertaining whether drag and drop URIs can be - accessed, something otherwise not provided for. */ - - descriptor = null; - - try - { - descriptor = resolver.openFileDescriptor (uri, "r"); - return true; - } - catch (Exception exception) - { - /* Ignored. */ - } - finally - { - try - { - if (descriptor != null) - descriptor.close (); - } - catch (IOException exception) - { - /* Ignored. */ - } - } + /* checkCallingUriPermission deals with permissions held by callers + of functions over the Binder IPC mechanism as contrasted with + Emacs itself, while getCallingPid and getCallingUid, despite the + class where they reside, return the process credentials against + which the system will actually test URIs being opened. */ - return false; + rc = checkUriPermission (uri, Binder.getCallingPid (), + Binder.getCallingUid (), flags); + return rc == PackageManager.PERMISSION_GRANTED; } /* Return a 8 character checksum for the string STRING, after encoding as UTF-8 data. */ - public static String + private static String getDisplayNameHash (String string) { byte[] encoded; @@ -1418,22 +1401,12 @@ public final class EmacsService extends Service otherwise. */ public String[] - getDocumentTrees (byte provider[]) + getDocumentTrees (String provider) { - String providerName; List<String> treeList; List<UriPermission> permissions; Uri uri; - try - { - providerName = new String (provider, "US-ASCII"); - } - catch (UnsupportedEncodingException exception) - { - return null; - } - permissions = resolver.getPersistedUriPermissions (); treeList = new ArrayList<String> (); @@ -1442,7 +1415,7 @@ public final class EmacsService extends Service uri = permission.getUri (); if (DocumentsContract.isTreeUri (uri) - && uri.getAuthority ().equals (providerName) + && uri.getAuthority ().equals (provider) && permission.isReadPermission ()) /* Make sure the tree document ID is encoded. Refrain from encoding characters such as +:&?#, since they don't @@ -1452,6 +1425,9 @@ public final class EmacsService extends Service " +:&?#")); } + /* The empty string array that is ostensibly allocated to provide + the first argument provides just the type of the array to be + returned. */ return treeList.toArray (new String[0]); } @@ -1973,6 +1949,21 @@ public final class EmacsService extends Service return false; } + /* Relinquish authorization for read and write access to the provided + URI, which is generally a reference to a directory tree. */ + + public void + relinquishUriRights (String uri) + { + Uri uri1; + int flags; + + uri1 = Uri.parse (uri); + flags = (Intent.FLAG_GRANT_READ_URI_PERMISSION + | Intent.FLAG_GRANT_WRITE_URI_PERMISSION); + resolver.releasePersistableUriPermission (uri1, flags); + } + /* Functions for detecting and requesting storage permissions. */ diff --git a/java/org/gnu/emacs/EmacsThread.java b/java/org/gnu/emacs/EmacsThread.java index 4adcb98b2f7..a90eb73b1ef 100644 --- a/java/org/gnu/emacs/EmacsThread.java +++ b/java/org/gnu/emacs/EmacsThread.java @@ -28,24 +28,20 @@ public final class EmacsThread extends Thread { private static final String TAG = "EmacsThread"; - /* Whether or not Emacs should be started with an additional - argument, and that additional argument if non-NULL. */ - private String extraStartupArgument; + /* Whether or not Emacs should be started with additional arguments, + and those additional arguments if non-NULL. */ + private final String[] extraStartupArguments; /* Runnable run to initialize Emacs. */ - private Runnable paramsClosure; - - /* Whether or not to open a file after starting Emacs. */ - private String fileToOpen; + private final Runnable paramsClosure; public EmacsThread (EmacsService service, Runnable paramsClosure, - String extraStartupArgument, String fileToOpen) + String[] extraStartupArguments) { super ("Emacs main thread"); - this.extraStartupArgument = extraStartupArgument; + this.extraStartupArguments = extraStartupArguments; this.paramsClosure = paramsClosure; - this.fileToOpen = fileToOpen; } @Override @@ -54,23 +50,15 @@ public final class EmacsThread extends Thread { String args[]; - if (fileToOpen == null) - { - if (extraStartupArgument == null) - args = new String[] { "libandroid-emacs.so", }; - else - args = new String[] { "libandroid-emacs.so", - extraStartupArgument, }; - } + if (extraStartupArguments == null) + args = new String[] { "libandroid-emacs.so", }; else { - if (extraStartupArgument == null) - args = new String[] { "libandroid-emacs.so", - fileToOpen, }; - else - args = new String[] { "libandroid-emacs.so", - extraStartupArgument, - fileToOpen, }; + /* Prepend "libandroid-emacs.so" to the list of arguments. */ + args = new String[extraStartupArguments.length + 1]; + args[0] = "libandroid-emacs.so"; + System.arraycopy (extraStartupArguments, 0, args, + 1, extraStartupArguments.length); } paramsClosure.run (); diff --git a/java/org/gnu/emacs/EmacsTileObject.java b/java/org/gnu/emacs/EmacsTileObject.java new file mode 100644 index 00000000000..2caa28cbcd6 --- /dev/null +++ b/java/org/gnu/emacs/EmacsTileObject.java @@ -0,0 +1,101 @@ +/* Communication module for Android terminals. -*- c-file-style: "GNU" -*- + +Copyright (C) 2024 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/>. */ + +package org.gnu.emacs; + +import android.graphics.Bitmap; +import android.graphics.BitmapShader; +import android.graphics.Canvas; +import android.graphics.ColorFilter; +import android.graphics.Paint; +import android.graphics.Rect; +import android.graphics.Shader.TileMode; + +/* This is a crude facsimilie of the BitmapDrawable class implementing + just enough of its functionality to support displaying stipples in + EmacsGC. */ + +public final class EmacsTileObject +{ + /* Color filter object set by EmacsGC. */ + private ColorFilter colorFilter; + + /* Bitmap object set by EmacsGC. */ + private Bitmap bitmap; + + /* Tiling modes on either axis. */ + private TileMode xTile, yTile; + + /* Destination rectangle. */ + private Rect boundsRect; + + /* Paint providing graphics properties for drawBitmap. */ + private Paint paint; + + + + public + EmacsTileObject (Bitmap stippleBitmap) + { + bitmap = stippleBitmap; + paint = new Paint (); + } + + public void + setBitmap (Bitmap newBitmap) + { + bitmap = newBitmap; + } + + public void + setBounds (Rect bounds) + { + boundsRect = bounds; + } + + public void + setTileModeXY (TileMode newXTile, TileMode newYTile) + { + xTile = newXTile; + yTile = newYTile; + } + + public void + setColorFilter (ColorFilter filterObject) + { + paint.setColorFilter (filterObject); + } + + public Bitmap + getBitmap () + { + return bitmap; + } + + /* Replicate `bitmap' over CANVAS so that boundsRect is covered with + copies thereof on the X axis, if xTile is REPEAT, and also on the Y + axis, if yTile is a like value. */ + + public void + draw (Canvas canvas) + { + paint.setShader (new BitmapShader (bitmap, xTile, yTile)); + canvas.drawRect (boundsRect, paint); + } +}; diff --git a/java/org/gnu/emacs/EmacsView.java b/java/org/gnu/emacs/EmacsView.java index 109208b2518..977ad90310d 100644 --- a/java/org/gnu/emacs/EmacsView.java +++ b/java/org/gnu/emacs/EmacsView.java @@ -708,12 +708,12 @@ public final class EmacsView extends ViewGroup contextMenu = null; popupActive = false; - /* It is not possible to know with 100% certainty which activity - is currently displaying the context menu. Loop through each - activity and call `closeContextMenu' instead. */ + /* It is not possible to know with 100% certainty which activity is + currently displaying the context menu. Loop over each activity + and call `closeContextMenu' instead. */ - for (EmacsWindowAttachmentManager.WindowConsumer consumer - : EmacsWindowAttachmentManager.MANAGER.consumers) + for (EmacsWindowManager.WindowConsumer consumer + : EmacsWindowManager.MANAGER.consumers) { if (consumer instanceof EmacsActivity) ((EmacsActivity) consumer).closeContextMenu (); diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java index 2baede1d2d0..9acdc9502cf 100644 --- a/java/org/gnu/emacs/EmacsWindow.java +++ b/java/org/gnu/emacs/EmacsWindow.java @@ -112,7 +112,7 @@ public final class EmacsWindow extends EmacsHandleObject private SparseArray<Coordinate> pointerMap; /* The window consumer currently attached, if it exists. */ - private EmacsWindowAttachmentManager.WindowConsumer attached; + private EmacsWindowManager.WindowConsumer attached; /* The window background scratch GC. foreground is always the window background. */ @@ -136,10 +136,10 @@ public final class EmacsWindow extends EmacsHandleObject there is no such window manager. */ private WindowManager windowManager; - /* The time of the last KEYCODE_VOLUME_DOWN release. This is used - to quit Emacs upon two rapid clicks of the volume down - button. */ - private long lastVolumeButtonRelease; + /* The time of the last release of the quit keycode, generally + KEYCODE_VOLUME_DOWN. This is used to signal quit upon two rapid + presses of such key. */ + private long lastQuitKeyRelease; /* Linked list of character strings which were recently sent as events. */ @@ -159,12 +159,20 @@ public final class EmacsWindow extends EmacsHandleObject values are -1 if no drag and drop operation is under way. */ private int dndXPosition, dndYPosition; + /* Identifier binding this window to the activity created for it, or + -1 if the window should be attached to system-created activities + (i.e. the activity launched by the system at startup). Value is + meaningless under API level 29 and earlier. */ + public long attachmentToken; + + /* Whether this window should be preserved during window pruning, + and whether this window has previously been attached to a task. */ + public boolean preserve, previouslyAttached; + public - EmacsWindow (short handle, final EmacsWindow parent, int x, int y, + EmacsWindow (final EmacsWindow parent, int x, int y, int width, int height, boolean overrideRedirect) { - super (handle); - rect = new Rect (x, y, x + width, y + height); pointerMap = new SparseArray<Coordinate> (); @@ -195,7 +203,7 @@ public final class EmacsWindow extends EmacsHandleObject }); } - scratchGC = new EmacsGC ((short) 0); + scratchGC = new EmacsGC (); /* Create the map of input method-committed strings. Keep at most ten strings in the map. */ @@ -255,12 +263,12 @@ public final class EmacsWindow extends EmacsHandleObject run () { ViewManager parent; - EmacsWindowAttachmentManager manager; + EmacsWindowManager manager; if (EmacsActivity.focusedWindow == EmacsWindow.this) EmacsActivity.focusedWindow = null; - manager = EmacsWindowAttachmentManager.MANAGER; + manager = EmacsWindowManager.MANAGER; view.setVisibility (View.GONE); /* If the window manager is set, use that instead. */ @@ -281,12 +289,12 @@ public final class EmacsWindow extends EmacsHandleObject } public void - setConsumer (EmacsWindowAttachmentManager.WindowConsumer consumer) + setConsumer (EmacsWindowManager.WindowConsumer consumer) { attached = consumer; } - public EmacsWindowAttachmentManager.WindowConsumer + public EmacsWindowManager.WindowConsumer getAttachedConsumer () { return attached; @@ -420,7 +428,7 @@ public final class EmacsWindow extends EmacsHandleObject public void run () { - EmacsWindowAttachmentManager manager; + EmacsWindowManager manager; WindowManager windowManager; Activity ctx; Object tem; @@ -431,7 +439,7 @@ public final class EmacsWindow extends EmacsHandleObject if (!overrideRedirect) { - manager = EmacsWindowAttachmentManager.MANAGER; + manager = EmacsWindowManager.MANAGER; /* If parent is the root window, notice that there are new children available for interested activities to pick @@ -527,9 +535,9 @@ public final class EmacsWindow extends EmacsHandleObject public void run () { - EmacsWindowAttachmentManager manager; + EmacsWindowManager manager; - manager = EmacsWindowAttachmentManager.MANAGER; + manager = EmacsWindowManager.MANAGER; view.setVisibility (View.GONE); @@ -781,6 +789,7 @@ public final class EmacsWindow extends EmacsHandleObject if ((event.getFlags () & KeyEvent.FLAG_CANCELED) != 0) return; + /* Dispatch the key press event that was deferred till now. */ EmacsNative.sendKeyPress (this.handle, event.getEventTime (), state, keyCode, unicode_char); } @@ -788,7 +797,7 @@ public final class EmacsWindow extends EmacsHandleObject EmacsNative.sendKeyRelease (this.handle, event.getEventTime (), state, keyCode, unicode_char); - if (keyCode == KeyEvent.KEYCODE_VOLUME_DOWN) + if (keyCode == EmacsNative.getQuitKeycode ()) { /* Check if this volume down press should quit Emacs. Most Android devices have no physical keyboard, so it @@ -796,10 +805,10 @@ public final class EmacsWindow extends EmacsHandleObject time = event.getEventTime (); - if (time - lastVolumeButtonRelease < 350) + if (time - lastQuitKeyRelease < 350) EmacsNative.quit (); - lastVolumeButtonRelease = time; + lastQuitKeyRelease = time; } } @@ -809,20 +818,13 @@ public final class EmacsWindow extends EmacsHandleObject EmacsActivity.invalidateFocus (gainFocus ? 6 : 5); } - /* Notice that the activity has been detached or destroyed. - - ISFINISHING is set if the activity is not the main activity, or - if the activity was not destroyed in response to explicit user - action. */ + /* Notice that the activity (or its task) has been detached or + destroyed by explicit user action. */ public void - onActivityDetached (boolean isFinishing) + onActivityDetached () { - /* Destroy the associated frame when the activity is detached in - response to explicit user action. */ - - if (isFinishing) - EmacsNative.sendWindowAction (this.handle, 0); + EmacsNative.sendWindowAction (this.handle, 0); } @@ -1312,11 +1314,11 @@ public final class EmacsWindow extends EmacsHandleObject public void run () { - EmacsWindowAttachmentManager manager; + EmacsWindowManager manager; ViewManager parent; /* First, detach this window if necessary. */ - manager = EmacsWindowAttachmentManager.MANAGER; + manager = EmacsWindowManager.MANAGER; manager.detachWindow (EmacsWindow.this); /* Also unparent this view. */ @@ -1548,10 +1550,11 @@ public final class EmacsWindow extends EmacsHandleObject { int[] array; - /* This is supposed to translate coordinates to the root - window. */ + /* This is supposed to translate coordinates to the root window, + whose origin point, in this context, is that of the toplevel + activity host to this view. */ array = new int[2]; - EmacsService.SERVICE.getLocationOnScreen (view, array); + EmacsService.SERVICE.getLocationInWindow (view, array); /* Now, the coordinates of the view should be in array. Offset X and Y by them. */ @@ -1858,7 +1861,7 @@ public final class EmacsWindow extends EmacsHandleObject public void recreateActivity () { - final EmacsWindowAttachmentManager.WindowConsumer attached; + final EmacsWindowManager.WindowConsumer attached; attached = this.attached; diff --git a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java deleted file mode 100644 index aae4e2ee49b..00000000000 --- a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java +++ /dev/null @@ -1,211 +0,0 @@ -/* Communication module for Android terminals. -*- c-file-style: "GNU" -*- - -Copyright (C) 2023-2024 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/>. */ - -package org.gnu.emacs; - -import java.util.ArrayList; -import java.util.List; - -import android.app.ActivityOptions; -import android.content.Intent; -import android.os.Build; -import android.util.Log; - -/* Code to paper over the differences in lifecycles between - "activities" and windows. There are four interfaces to an instance - of this class: - - registerWindowConsumer (WindowConsumer) - registerWindow (EmacsWindow) - removeWindowConsumer (WindowConsumer) - removeWindow (EmacsWindow) - - A WindowConsumer is expected to allow an EmacsWindow to be attached - to it, and be created or destroyed. - - Every time a window is created, registerWindow checks the list of - window consumers. If a consumer exists and does not currently have - a window of its own attached, it gets the new window. Otherwise, - the window attachment manager starts a new consumer. - - Every time a consumer is registered, registerWindowConsumer checks - the list of available windows. If a window exists and is not - currently attached to a consumer, then the consumer gets it. - - Finally, every time a window is removed, the consumer is - destroyed. */ - -public final class EmacsWindowAttachmentManager -{ - private final static String TAG = "EmacsWindowAttachmentManager"; - - /* The single window attachment manager ``object''. */ - public static final EmacsWindowAttachmentManager MANAGER; - - static - { - MANAGER = new EmacsWindowAttachmentManager (); - }; - - public interface WindowConsumer - { - public void attachWindow (EmacsWindow window); - public EmacsWindow getAttachedWindow (); - public void detachWindow (); - public void destroy (); - }; - - /* List of currently attached window consumers. */ - public List<WindowConsumer> consumers; - - /* List of currently attached windows. */ - public List<EmacsWindow> windows; - - public - EmacsWindowAttachmentManager () - { - consumers = new ArrayList<WindowConsumer> (); - windows = new ArrayList<EmacsWindow> (); - } - - public void - registerWindowConsumer (WindowConsumer consumer) - { - consumers.add (consumer); - - for (EmacsWindow window : windows) - { - if (window.getAttachedConsumer () == null) - { - consumer.attachWindow (window); - return; - } - } - - EmacsNative.sendWindowAction ((short) 0, 0); - } - - public synchronized void - registerWindow (EmacsWindow window) - { - Intent intent; - ActivityOptions options; - - if (windows.contains (window)) - /* The window is already registered. */ - return; - - windows.add (window); - - for (WindowConsumer consumer : consumers) - { - if (consumer.getAttachedWindow () == null) - { - consumer.attachWindow (window); - return; - } - } - - intent = new Intent (EmacsService.SERVICE, - EmacsMultitaskActivity.class); - - intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK - | Intent.FLAG_ACTIVITY_MULTIPLE_TASK); - - /* Intent.FLAG_ACTIVITY_NEW_DOCUMENT is lamentably unavailable on - older systems than Lolipop. */ - if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP) - intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT); - - if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N) - EmacsService.SERVICE.startActivity (intent); - else - { - /* Specify the desired window size. */ - options = ActivityOptions.makeBasic (); - options.setLaunchBounds (window.getGeometry ()); - EmacsService.SERVICE.startActivity (intent, - options.toBundle ()); - } - } - - public void - removeWindowConsumer (WindowConsumer consumer, boolean isFinishing) - { - EmacsWindow window; - - window = consumer.getAttachedWindow (); - - if (window != null) - { - consumer.detachWindow (); - window.onActivityDetached (isFinishing); - } - - consumers.remove (consumer); - } - - public synchronized void - detachWindow (EmacsWindow window) - { - WindowConsumer consumer; - - if (window.getAttachedConsumer () != null) - { - consumer = window.getAttachedConsumer (); - - consumers.remove (consumer); - consumer.destroy (); - } - - windows.remove (window); - } - - public void - noticeIconified (WindowConsumer consumer) - { - EmacsWindow window; - - /* If a window is attached, send the appropriate iconification - events. */ - window = consumer.getAttachedWindow (); - - if (window != null) - window.noticeIconified (); - } - - public void - noticeDeiconified (WindowConsumer consumer) - { - EmacsWindow window; - - /* If a window is attached, send the appropriate iconification - events. */ - window = consumer.getAttachedWindow (); - - if (window != null) - window.noticeDeiconified (); - } - - public synchronized List<EmacsWindow> - copyWindows () - { - return new ArrayList<EmacsWindow> (windows); - } -}; diff --git a/java/org/gnu/emacs/EmacsWindowManager.java b/java/org/gnu/emacs/EmacsWindowManager.java new file mode 100644 index 00000000000..23dc71dbd29 --- /dev/null +++ b/java/org/gnu/emacs/EmacsWindowManager.java @@ -0,0 +1,429 @@ +/* Communication module for Android terminals. -*- c-file-style: "GNU" -*- + +Copyright (C) 2023-2024 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/>. */ + +package org.gnu.emacs; + +import java.util.ArrayList; +import java.util.List; + +import android.app.ActivityManager.AppTask; +import android.app.ActivityManager.RecentTaskInfo; +import android.app.ActivityManager; +import android.app.ActivityOptions; + +import android.content.ComponentName; +import android.content.Context; +import android.content.Intent; + +import android.os.Build; + +import android.util.Log; + +/* Code to paper over the differences in lifecycles between + "activities" and windows. + + Four of the five interfaces to be implemented by an instance of this + class are relevant on all versions of Android: + + registerWindowConsumer (WindowConsumer) + registerWindow (EmacsWindow) + removeWindowConsumer (WindowConsumer) + removeWindow (EmacsWindow) + + A WindowConsumer is expected to allow an EmacsWindow to be attached + to it, and be created or destroyed. + + Whenever a window is created, registerWindow examines the list of + window consumers. If a consumer exists and does not currently have a + window of its own attached, it gets the new window, while otherwise, + the window attachment manager starts a new consumer. Whenever a + consumer is registered, registerWindowConsumer checks the list of + available windows. If a window exists and is not currently attached + to a consumer, then the consumer gets it. Finally, every time a + window is removed, the consumer is destroyed. + + getAttachmentToken () + + should return a token uniquely identifying a consumer, which, on API + 21 and up, enables attributing the tasks of activities to the windows + for which they were created, and with that, consistent interaction + between user-visible window state and their underlying frames. */ + +public final class EmacsWindowManager +{ + private static final String TAG = "EmacsWindowManager"; + public final static String ACTIVITY_TOKEN = "emacs:activity_token"; + + /* The single window attachment manager ``object''. */ + public static final EmacsWindowManager MANAGER; + + /* Monotonically increasing counter from which multitasking activity + tokens are produced. */ + private static long nextActivityToken; + + /* The ActivityManager. */ + private ActivityManager activityManager; + + static + { + MANAGER = new EmacsWindowManager (); + }; + + interface WindowConsumer + { + public void attachWindow (EmacsWindow window); + public EmacsWindow getAttachedWindow (); + public void detachWindow (); + public void destroy (); + public long getAttachmentToken (); + }; + + /* List of currently attached window consumers. */ + public List<WindowConsumer> consumers; + + /* List of currently attached windows. */ + public List<EmacsWindow> windows; + + public + EmacsWindowManager () + { + consumers = new ArrayList<WindowConsumer> (); + windows = new ArrayList<EmacsWindow> (); + } + + + + + /* Return whether the provided WINDOW should be attached to the window + consumer CONSUMER. */ + + public static boolean + isWindowEligible (WindowConsumer consumer, EmacsWindow window) + { + return (/* The window has yet to be bound. */ + window.attachmentToken == 0 + /* Or has already been bound to CONSUMER. */ + || (window.attachmentToken + == consumer.getAttachmentToken ())); + } + + + + public synchronized void + registerWindowConsumer (WindowConsumer consumer) + { + consumers.add (consumer); + pruneWindows (); + + for (EmacsWindow window : windows) + { + if (window.getAttachedConsumer () == null + /* Don't attach this window to CONSUMER if incompatible. */ + && isWindowEligible (consumer, window)) + { + /* Permantly bind this window to the consumer. */ + window.attachmentToken = consumer.getAttachmentToken (); + window.previouslyAttached = true; + consumer.attachWindow (window); + return; + } + } + + EmacsNative.sendWindowAction (0, 0); + } + + public synchronized void + registerWindow (EmacsWindow window) + { + Intent intent; + ActivityOptions options; + long token; + + if (windows.contains (window)) + /* The window is already registered. */ + return; + + windows.add (window); + + for (WindowConsumer consumer : consumers) + { + if (consumer.getAttachedWindow () == null + && isWindowEligible (consumer, window)) + { + /* Permantly bind this window to the consumer. */ + window.attachmentToken = consumer.getAttachmentToken (); + window.previouslyAttached = true; + consumer.attachWindow (window); + return; + } + } + + intent = new Intent (EmacsService.SERVICE, + EmacsMultitaskActivity.class); + + /* FLAG_ACTIVITY_MULTIPLE_TASK would appear appropriate, but that + is not so: on Android 2.3 and earlier, this flag combined with + FLAG_ACTIVITY_NEW_TASK prompts the task switcher to create a + new instance of EmacsMultitaskActivity, rather than return to + an existing instance, and is entirely redundant, inasmuch as + only one multitasking task can exist at any given moment. */ + intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK); + + /* Intent.FLAG_ACTIVITY_NEW_DOCUMENT is lamentably unavailable on + older systems than Lolipop. */ + if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP) + { + intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT + | Intent.FLAG_ACTIVITY_MULTIPLE_TASK); + + /* Bind this window to the activity in advance, i.e., before its + creation, so that its ID will be recorded in the RecentTasks + list. */ + token = ++nextActivityToken; + } + else + /* APIs required for linking activities to windows are not + available in earlier Android versions. */ + token = -2; + + window.attachmentToken = token; + intent.putExtra (ACTIVITY_TOKEN, token); + + if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N) + EmacsService.SERVICE.startActivity (intent); + else + { + /* Specify the desired window size. */ + options = ActivityOptions.makeBasic (); + options.setLaunchBounds (window.getGeometry ()); + EmacsService.SERVICE.startActivity (intent, options.toBundle ()); + } + + pruneWindows (); + } + + public synchronized void + removeWindowConsumer (WindowConsumer consumer, boolean isFinishing) + { + EmacsWindow window; + + window = consumer.getAttachedWindow (); + + if (window != null) + { + consumer.detachWindow (); + + /* Though pruneWindows will likely remove the same window(s), + call onActivityDetached anyway if isFinishing is set, if + CONSUMER not be a multitasking activity, as in obscure + circumstances pruneWindows will not remove frames bound to + the system-started task. */ + if (isFinishing + && (!(consumer instanceof EmacsMultitaskActivity) + || Build.VERSION.SDK_INT < Build.VERSION_CODES.LOLLIPOP)) + window.onActivityDetached (); + } + + pruneWindows (); + consumers.remove (consumer); + } + + public synchronized void + detachWindow (EmacsWindow window) + { + WindowConsumer consumer; + + /* Reset window management state. */ + window.previouslyAttached = false; + window.attachmentToken = 0; + + /* Remove WINDOW from the list of active windows. */ + windows.remove (window); + + if ((consumer = window.getAttachedConsumer ()) != null) + { + consumers.remove (consumer); + consumer.destroy (); + } + + pruneWindows (); + } + + public void + noticeIconified (WindowConsumer consumer) + { + EmacsWindow window; + + /* If a window is attached, send the appropriate iconification + events. */ + window = consumer.getAttachedWindow (); + + if (window != null) + window.noticeIconified (); + } + + public void + noticeDeiconified (WindowConsumer consumer) + { + EmacsWindow window; + + /* If a window is attached, send the appropriate iconification + events. */ + window = consumer.getAttachedWindow (); + + if (window != null) + window.noticeDeiconified (); + } + + public synchronized List<EmacsWindow> + copyWindows () + { + return new ArrayList<EmacsWindow> (windows); + } + + + + /* Return the activity token specified in the intent giving rise to + TASK, or 0 if absent. */ + + private static long + getTaskToken (AppTask task) + { + RecentTaskInfo info; + + info = task.getTaskInfo (); + + /* baseIntent is a member of info's superclass, TaskInfo, on Android + 10 and later. Prior to this release, it had been a member of + RecentTaskInfo since SDK 1, and whatever the misleading + documentation might suggest, a reference to `baseIntent' through + TaskInfo is just as good a reference to RecentTaskInfo. */ + return (info.baseIntent != null + ? info.baseIntent.getLongExtra (ACTIVITY_TOKEN, -1l) + : 0); + } + + /* Iterate over each of Emacs's tasks and remove remaining registered + windows whose tasks no longer exist. This function should be + called upon any event that could plausibly indicate changes in the + task list or as to window management. */ + + private synchronized void + pruneWindows () + { + Object object; + List<AppTask> appTasks; + long taskToken; + boolean set; + + if (Build.VERSION.SDK_INT < Build.VERSION_CODES.LOLLIPOP + || EmacsService.SERVICE == null) + return; + + if (activityManager == null) + { + object + = EmacsService.SERVICE.getSystemService (Context.ACTIVITY_SERVICE); + activityManager = (ActivityManager) object; + } + + appTasks = activityManager.getAppTasks (); + + /* Clear the preserve flag on all toplevel windows. */ + + for (EmacsWindow window : windows) + window.preserve = false; + + for (AppTask task : appTasks) + { + taskToken = getTaskToken (task); + set = false; + + if (taskToken == 0) + continue; + + /* Search for a window with this token. */ + for (EmacsWindow window : windows) + { + if (window.attachmentToken == taskToken) + { + window.preserve = true; + set = true; + } + } + + if (!set) + task.finishAndRemoveTask (); + } + + /* Now remove toplevel windows without activity tasks. */ + + for (EmacsWindow window : windows) + { + if (window.preserve + /* This is not the initial window. */ + || (window.attachmentToken < 1) + /* Nor has it never been attached. */ + || !window.previouslyAttached) + continue; + + window.onActivityDetached (); + } + } + + /* Iterate over each of Emacs's tasks to delete such as belong to a + previous Emacs session, i.e., tasks created for a previous + session's non-initial frames. CONTEXT should be a context from + which to obtain a reference to the activity manager. */ + + public void + removeOldTasks (Context context) + { + List<AppTask> appTasks; + RecentTaskInfo info; + ComponentName name; + String target; + Object object; + + if (Build.VERSION.SDK_INT < Build.VERSION_CODES.LOLLIPOP) + return; + + if (activityManager == null) + { + object = context.getSystemService (Context.ACTIVITY_SERVICE); + activityManager = (ActivityManager) object; + } + + appTasks = activityManager.getAppTasks (); + target = ".EmacsMultitaskActivity"; + + for (AppTask task : appTasks) + { + info = task.getTaskInfo (); + + /* Test whether info is a reference to + EmacsMultitaskActivity. */ + if (info.baseIntent != null + && (name = info.baseIntent.getComponent ()) != null + && name.getShortClassName ().equals (target)) + /* Delete the task. */ + task.finishAndRemoveTask (); + } + } +}; diff --git a/java/proguard.conf b/java/proguard.conf new file mode 100644 index 00000000000..5da402946bb --- /dev/null +++ b/java/proguard.conf @@ -0,0 +1,53 @@ +# Proguard configuration files for Emacs +# +# Copyright (C) 2024 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/>. +# +# The effect of the following lines is to inhibit the removal of variable or +# method symbol names from symbols referenced from C. + +-keep,allowoptimization class org.gnu.emacs.EmacsClipboard { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsContextMenu { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsCursor { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsDesktopNotification { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsDialog { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsDirectoryEntry { public <fields>; } +-keep,allowoptimization class org.gnu.emacs.EmacsFontDriver { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsFontDriver$* { public <fields>; } +-keep,allowoptimization class org.gnu.emacs.EmacsGC { public <methods>; public <fields>; } +-keep,allowoptimization class org.gnu.emacs.EmacsHandleObject { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsPixmap { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsService { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsWindow { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsNative { public <methods>; } +-keep,allowoptimization class org.gnu.emacs.EmacsNoninteractive { public <methods>; } +-keep,allowoptimization interface org.gnu.emacs.EmacsDrawable { public <methods>; } + +# And these lines inhibit the deletion of symbols that are referenced by +# the operating system while enabling the compiler to minify or delete +# symbols only referenced internally. + +-keep,allowoptimization,allowaccessmodification public class * extends android.app.Activity +-keep,allowoptimization,allowaccessmodification public class * extends android.app.Application +-keep,allowoptimization,allowaccessmodification public class * extends android.app.Service +-keep,allowoptimization,allowaccessmodification public class * extends android.content.BroadcastReceiver +-keep,allowoptimization,allowaccessmodification public class * extends android.content.ContentProvider + +# Local Variables: +# truncate-lines: t +# indent-tabs-mode: nil +# End: diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index ea34d5f7b93..79db1ef2f47 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -1460,8 +1460,8 @@ local_sockname (int s, char sockname[socknamesize], int tmpdirlen, this user's directory and does not let others write to it; this fends off some symlink attacks. To avoid races, keep the parent directory open while checking. */ - char *emacsdirend = sockname + tmpdirlen + suffixlen - - strlen(server_name) - 1; + char *emacsdirend = (sockname + tmpdirlen + suffixlen + - strlen (server_name) - 1); *emacsdirend = '\0'; int dir = open (sockname, O_PATH | O_DIRECTORY | O_NOFOLLOW | O_CLOEXEC); *emacsdirend = '/'; @@ -1505,6 +1505,7 @@ set_local_socket (char const *server_name) } else { +#ifndef HAVE_ANDROID /* socket_name is a file name component. */ char const *xdg_runtime_dir = egetenv ("XDG_RUNTIME_DIR"); if (xdg_runtime_dir) @@ -1534,10 +1535,35 @@ set_local_socket (char const *server_name) if (tmpdirlen < 0) tmpdirlen = snprintf (sockname, socknamesize, "/tmp"); } + sock_status = local_sockname (s, sockname, tmpdirlen, uid, server_name); tmpdir_used = true; } +#else /* HAVE_ANDROID */ + char const *tmpdir; + int socknamelen; + uintmax_t uidmax; + + /* The TMPDIR of any process to which this binary is + accessible must be reserved for Emacs, so the checks in + local_sockname and the like are redundant. */ + tmpdir = egetenv ("TMPDIR"); + + /* Resort to the usual location of the cache directory, though + this location is not guaranteed to remain stable over + future releases of Android. */ + if (!tmpdir) + tmpdir = "/data/data/org.gnu.emacs/cache"; + + uidmax = uid; + socknamelen = snprintf (sockname, socknamesize, + "%s/emacs%"PRIuMAX"/%s", + tmpdir, uidmax, server_name); + sock_status = (0 <= socknamelen && socknamelen < socknamesize + ? connect_socket (AT_FDCWD, sockname, s, 0) + : ENAMETOOLONG); +#endif /* !HAVE_ANDROID */ } if (sock_status == 0) diff --git a/lib-src/etags.c b/lib-src/etags.c index 032cfa8010b..84dfa527e98 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -143,6 +143,12 @@ University of California, as described above. */ # define MERCURY_HEURISTICS_RATIO 0.5 #endif +/* Work around GCC bug 114882 + <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=114882>. */ +#if GNUC_PREREQ (14, 0, 0) +# pragma GCC diagnostic ignored "-Wanalyzer-use-of-uninitialized-value" +#endif + /* COPY to DEST from SRC (containing LEN bytes), and append a NUL byte. */ static void memcpyz (void *dest, void const *src, ptrdiff_t len) @@ -243,12 +249,10 @@ endtoken (unsigned char c) } /* - * xnew, xrnew -- allocate, reallocate storage + * xrnew -- reallocate storage * - * SYNOPSIS: Type *xnew (ptrdiff_t n, Type); - * void xrnew (OldPointer, ptrdiff_t n, int multiplier); + * SYNOPSIS: void xrnew (OldPointer, ptrdiff_t n, int multiplier); */ -#define xnew(n, Type) ((Type *) xnmalloc (n, sizeof (Type))) #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op))) typedef void Lang_function (FILE *); @@ -1125,13 +1129,13 @@ main (int argc, char **argv) progname = argv[0]; nincluded_files = 0; - included_files = xnew (argc, char *); + included_files = xnmalloc (argc, sizeof *included_files); current_arg = 0; file_count = 0; /* Allocate enough no matter what happens. Overkill, but each one is small. */ - argbuffer = xnew (argc, argument); + argbuffer = xnmalloc (argc, sizeof *argbuffer); /* * Always find typedefs and structure tags. @@ -1778,7 +1782,7 @@ process_file (FILE *fh, char *fn, language *lang) infilename = fn; /* Create a new input file description entry. */ - fdp = xnew (1, fdesc); + fdp = xmalloc (sizeof *fdp); *fdp = emptyfdesc; fdp->next = fdhead; fdp->infname = savestr (fn); @@ -2080,7 +2084,7 @@ pfnote (char *name, /* tag name, or NULL if unnamed */ || (!CTAGS && name && name[0] == '\0')) return; - np = xnew (1, node); + np = xmalloc (sizeof *np); /* If ctags mode, change name "main" to M<thisfilename>. */ if (CTAGS && !cxref_style && streq (name, "main")) @@ -2135,7 +2139,7 @@ push_node (node *np, stkentry **stack_top) { if (np) { - stkentry *new = xnew (1, stkentry); + stkentry *new = xmalloc (sizeof *new); new->np = np; new->next = *stack_top; @@ -3425,8 +3429,8 @@ C_entries (int c_ext, /* extension of C */ { cstack.size = (DEBUG) ? 1 : 4; cstack.nl = 0; - cstack.cname = xnew (cstack.size, char *); - cstack.bracelev = xnew (cstack.size, ptrdiff_t); + cstack.cname = xnmalloc (cstack.size, sizeof *cstack.cname); + cstack.bracelev = xnmalloc (cstack.size, sizeof *cstack.bracelev); } tokoff = toklen = typdefbracelev = 0; /* keep compiler quiet */ @@ -5077,7 +5081,7 @@ Ruby_functions (FILE *inf) if (writer) { size_t name_len = cp - np + 1; - char *wr_name = xnew (name_len + 1, char); + char *wr_name = xmalloc (name_len + 1); strcpy (mempcpy (wr_name, np, name_len - 1), "="); pfnote (wr_name, true, lb.buffer, cp - lb.buffer + 1, @@ -5854,7 +5858,7 @@ TEX_decode_env (const char *evarname, const char *defenv) for (p = env; (p = strchr (p, ':')); ) if (*++p) len++; - TEX_toktab = xnew (len, linebuffer); + TEX_toktab = xnmalloc (len, sizeof *TEX_toktab); /* Unpack environment string into token table. Be careful about */ /* zero-length strings (leading ':', "::" and trailing ':') */ @@ -7033,7 +7037,7 @@ add_regex (char *regexp_pattern, language *lang) break; } - patbuf = xnew (1, struct re_pattern_buffer); + patbuf = xmalloc (sizeof *patbuf); *patbuf = zeropattern; if (ignore_case) { @@ -7064,7 +7068,7 @@ add_regex (char *regexp_pattern, language *lang) } rp = p_head; - p_head = xnew (1, regexp); + p_head = xmalloc (sizeof *p_head); p_head->pattern = savestr (regexp_pattern); p_head->p_next = rp; p_head->lang = lang; @@ -7104,7 +7108,7 @@ substitute (char *in, char *out, struct re_registers *regs) /* Allocate space and do the substitutions. */ assert (size >= 0); - result = xnew (size + 1, char); + result = xmalloc (size + 1); for (t = result; *out != '\0'; out++) if (*out == '\\' && c_isdigit (*++out)) @@ -7377,26 +7381,26 @@ readline (linebuffer *lbp, FILE *stream) /* Check whether this is a #line directive. */ if (result > 12 && strneq (lbp->buffer, "#line ", 6)) { - intmax_t lno; - int start = 0; + char *lno_start = lbp->buffer + 6; + char *lno_end; + intmax_t lno = strtoimax (lno_start, &lno_end, 10); + char *quoted_filename + = lno_start < lno_end ? skip_spaces (lno_end) : NULL; - if (sscanf (lbp->buffer, "#line %"SCNdMAX" \"%n", &lno, &start) >= 1 - && start > 0) /* double quote character found */ + if (quoted_filename && *quoted_filename == '"') { - char *endp = lbp->buffer + start; + char *endp = quoted_filename; + while (*++endp && *endp != '"') + endp += *endp == '\\' && endp[1]; - while ((endp = strchr (endp, '"')) != NULL - && endp[-1] == '\\') - endp++; - if (endp != NULL) + if (*endp) /* Ok, this is a real #line directive. Let's deal with it. */ { char *taggedabsname; /* absolute name of original file */ char *taggedfname; /* name of original file as given */ - char *name; /* temp var */ + char *name = quoted_filename + 1; discard_until_line_directive = false; /* found it */ - name = lbp->buffer + start; *endp = '\0'; canonicalize_filename (name); taggedabsname = absolute_filename (name, tagfiledir); @@ -7452,7 +7456,7 @@ readline (linebuffer *lbp, FILE *stream) if (fdp == NULL) /* not found */ { fdp = fdhead; - fdhead = xnew (1, fdesc); + fdhead = xmalloc (sizeof *fdhead); *fdhead = *curfdp; /* copy curr. file description */ fdhead->next = fdp; fdhead->infname = savestr (curfdp->infname); @@ -7552,7 +7556,7 @@ readline (linebuffer *lbp, FILE *stream) /* * Return a pointer to a space of size strlen(cp)+1 allocated - * with xnew where the string CP has been copied. + * with xmalloc where the string CP has been copied. */ static char * savestr (const char *cp) @@ -7561,13 +7565,13 @@ savestr (const char *cp) } /* - * Return a pointer to a space of size LEN+1 allocated with xnew + * Return a pointer to a space of size LEN+1 allocated with xmalloc * with a copy of CP (containing LEN bytes) followed by a NUL byte. */ static char * savenstr (const char *cp, ptrdiff_t len) { - char *dp = xnew (len + 1, char); + char *dp = xmalloc (len + 1); dp[len] = '\0'; return memcpy (dp, cp, len); } @@ -7650,7 +7654,7 @@ static char * concat (const char *s1, const char *s2, const char *s3) { ptrdiff_t len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3); - char *result = xnew (len1 + len2 + len3 + 1, char); + char *result = xmalloc (len1 + len2 + len3 + 1); strcpy (stpcpy (stpcpy (result, s1), s2), s3); return result; } @@ -7662,7 +7666,7 @@ static char * etags_getcwd (void) { ptrdiff_t bufsize = 200; - char *path = xnew (bufsize, char); + char *path = xmalloc (bufsize); while (getcwd (path, bufsize) == NULL) { @@ -7748,7 +7752,7 @@ escape_shell_arg_string (char *str) p++; } - char *new_str = xnew (need_space + 1, char); + char *new_str = xmalloc (need_space + 1); new_str[0] = '\''; new_str[need_space-1] = '\''; @@ -7841,7 +7845,7 @@ relative_filename (char *file, char *dir) i = 0; while ((dp = strchr (dp + 1, '/')) != NULL) i += 1; - res = xnew (3*i + strlen (fp + 1) + 1, char); + res = xmalloc (3*i + strlen (fp + 1) + 1); char *z = res; while (i-- > 0) z = stpcpy (z, "../"); @@ -7996,7 +8000,7 @@ static void linebuffer_init (linebuffer *lbp) { lbp->size = (DEBUG) ? 3 : 200; - lbp->buffer = xnew (lbp->size, char); + lbp->buffer = xmalloc (lbp->size); lbp->buffer[0] = '\0'; lbp->len = 0; } diff --git a/lib-src/rcs2log b/lib-src/rcs2log index 61301e7246d..94234d01c98 100755 --- a/lib-src/rcs2log +++ b/lib-src/rcs2log @@ -261,10 +261,10 @@ case $rlogfile in if test -s "$changelog" then extractTZ=' - /^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*"\([^"]*\)".*/{ + /^.*-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*"\([^"]*\)".*/{ s//\1/; p; q } - /^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*t.*/{ + /^.*-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*t.*/{ s//UTC0/; p; q } ' diff --git a/lisp/align.el b/lisp/align.el index 81ccc4b5e2d..6c393f7ee26 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -126,15 +126,13 @@ (defcustom align-load-hook nil "Hook that gets run after the aligner has been loaded." - :type 'hook - :group 'align) + :type 'hook) (make-obsolete-variable 'align-load-hook "use `with-eval-after-load' instead." "28.1") (defcustom align-indent-before-aligning nil "If non-nil, indent the marked region before aligning it." - :type 'boolean - :group 'align) + :type 'boolean) (defcustom align-default-spacing 1 "An integer that represents the default amount of padding to use. @@ -142,14 +140,12 @@ If `align-to-tab-stop' is non-nil, this will represent the number of tab stops to use for alignment, rather than the number of spaces. Each alignment rule can optionally override both this variable and `align-to-tab-stop'. See `align-rules-list'." - :type 'integer - :group 'align) + :type 'integer) (defcustom align-to-tab-stop 'indent-tabs-mode "If non-nil, alignments will always fall on a tab boundary. It may also be a symbol, whose value will be taken." - :type '(choice (const nil) symbol) - :group 'align) + :type '(choice (const nil) symbol)) (defcustom align-region-heuristic 500 "If non-nil, used as a heuristic by `align-current'. @@ -160,66 +156,55 @@ point we should search in looking for a region separator. Larger values can mean slower performance in large files, although smaller values may cause unexpected behavior at times." :type '(choice (const :tag "Don't use heuristic when aligning a region" nil) - integer) - :group 'align) + integer)) (defcustom align-highlight-change-face 'highlight "The face to highlight with if changes are necessary. Used by the `align-highlight-rule' command." - :type 'face - :group 'align) + :type 'face) (defcustom align-highlight-nochange-face 'secondary-selection "The face to highlight with if no changes are necessary. Used by the `align-highlight-rule' command." - :type 'face - :group 'align) + :type 'face) (defcustom align-large-region 10000 "If an integer, defines what constitutes a \"large\" region. If nil, then no messages will ever be printed to the minibuffer." - :type '(choice (const :tag "Align a large region silently" nil) integer) - :group 'align) + :type '(choice (const :tag "Align a large region silently" nil) integer)) (defcustom align-c++-modes '( c++-mode c-mode java-mode) "A list of modes whose syntax resembles C/C++." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-perl-modes '(perl-mode) "A list of modes where Perl syntax is to be seen." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-lisp-modes '(emacs-lisp-mode lisp-interaction-mode lisp-mode scheme-mode) "A list of modes whose syntax resembles Lisp." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-tex-modes '(tex-mode plain-tex-mode latex-mode slitex-mode) "A list of modes whose syntax resembles TeX (and family)." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-text-modes '(text-mode outline-mode) "A list of modes whose content is plain text." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-dq-string-modes (append align-lisp-modes align-c++-modes align-perl-modes '(python-base-mode vhdl-mode)) "A list of modes where double quoted strings should be excluded." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-sq-string-modes (append align-perl-modes '(python-base-mode)) "A list of modes where single quoted strings should be excluded." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-open-comment-modes (append align-lisp-modes align-c++-modes align-perl-modes @@ -227,8 +212,7 @@ If nil, then no messages will ever be printed to the minibuffer." "A list of modes with a single-line comment syntax. These are comments as in Lisp, which have a beginning, but end with the line (i.e., `comment-end' is an empty string)." - :type '(repeat symbol) - :group 'align) + :type '(repeat symbol)) (defcustom align-region-separate "^\\s-*[{}]?\\s-*$" "Select the method by which alignment sections will be separated. @@ -317,11 +301,10 @@ The possible settings for `align-region-separate' are: :type '(choice (const :tag "Entire region is one section" entire) (const :tag "Align by contiguous groups" group) -; (const largest) + ;; (const largest) (regexp :tag "Regexp defines section boundaries") (function :tag "Function defines section boundaries")) - :risky t - :group 'align) + :risky t) (defvar align-rules-list-type '(repeat @@ -537,10 +520,8 @@ The possible settings for `align-region-separate' are: (regexp . ,(lambda (end reverse) (align-match-tex-pattern "\\\\[=>]" end reverse))) (group . (1 2)) - (modes . align-tex-modes) - (repeat . t) - (run-if . ,(lambda () - (eq major-mode 'latex-mode)))) + (modes . '(latex-mode)) + (repeat . t)) (tex-record-break (regexp . "\\(\\s-*\\)\\\\\\\\") @@ -716,8 +697,7 @@ The following attributes are meaningful: (see the documentation of that variable for possible values), and any separation argument passed to `align'." :type align-rules-list-type - :risky t - :group 'align) + :risky t) (defvar align-exclude-rules-list-type '(repeat @@ -786,8 +766,7 @@ The following attributes are meaningful: "A list describing text that should be excluded from alignment. See the documentation for `align-rules-list' for more info." :type align-exclude-rules-list-type - :risky t - :group 'align) + :risky t) ;;; Internal Variables: @@ -838,8 +817,7 @@ See the variable `align-exclude-rules-list' for more details.") (regexp . "\\(\\s-+\\)use\\s-+entity"))) "Alignment rules for `vhdl-mode'. See `align-rules-list' for more info." :type align-rules-list-type - :risky t - :group 'align) + :risky t) (make-obsolete-variable 'align-vhdl-rules-list "no longer used." "27.1") (defun align-set-vhdl-rules () diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 5f5629d9cfc..2de78c5ae55 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -41,6 +41,7 @@ (require 'json) (require 'password-cache) +(require 'icons) (require 'cl-lib) (require 'eieio) @@ -2441,6 +2442,179 @@ point is moved into the passwords (see `authinfo-hide-elements'). (propertize "****" 'face 'font-lock-doc-face)) (overlay-put overlay 'display nil))) +;; It would be preferable to use "👁" ("\N{EYE}"). However, there is +;; no corresponding Unicode char with a slash. So we use symbols as +;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for +;; hiding the password. +(define-icon read-passwd--show-password-icon nil + '((image "reveal.svg" "reveal.pbm" :height (0.8 . em)) + (symbol "👁") + (text "<o>")) + "Mode line icon to show a hidden password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + +(define-icon read-passwd--hide-password-icon nil + '((image "conceal.svg" "conceal.pbm" :height (0.8 . em)) + (symbol "⦵") + (text "<\\>")) + "Mode line icon to hide a visible password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + +(defvar read-passwd--mode-line-buffer nil + "Buffer to modify `mode-line-format' for showing/hiding passwords.") + +(defvar read-passwd--mode-line-icon nil + "Propertized mode line icon for showing/hiding passwords.") + +(defvar read-passwd--hide-password t + "Toggle whether password should be hidden in minubuffer.") + +(defun read-passwd--hide-password () + "Make password in minibuffer hidden or visible." + (let ((beg (minibuffer-prompt-end))) + (dotimes (i (1+ (- (buffer-size) beg))) + (if read-passwd--hide-password + (put-text-property + (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*))) + (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display))) + (put-text-property + (+ i beg) (+ 1 i beg) + 'help-echo "C-u: Clear password\nTAB: Toggle password visibility")))) + +(defun read-passwd-toggle-visibility () + "Toggle minibuffer contents visibility. +Adapt also mode line." + (interactive) + (let ((win (active-minibuffer-window))) + (unless win (error "No active minibuffer")) + ;; FIXME: In case of a recursive minibuffer, this may select the wrong + ;; mini-buffer. + (with-current-buffer (window-buffer win) + (setq read-passwd--hide-password (not read-passwd--hide-password)) + (with-current-buffer read-passwd--mode-line-buffer + (setq read-passwd--mode-line-icon + `(:propertize + ,(if icon-preference + (icon-string + (if read-passwd--hide-password + 'read-passwd--show-password-icon + 'read-passwd--hide-password-icon)) + "") + mouse-face mode-line-highlight + keymap + ,(eval-when-compile + (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] + #'read-passwd-toggle-visibility) + map)))) + (force-mode-line-update)) + (read-passwd--hide-password)))) + +(defvar read-passwd-map + ;; BEWARE: `defconst' would purecopy it, breaking the sharing with + ;; minibuffer-local-map along the way! + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 + (define-key map "\t" #'read-passwd-toggle-visibility) + map) + "Keymap used while reading passwords.") + +(define-minor-mode read-passwd-mode + "Toggle visibility of password in minibuffer." + :group 'mode-line + :group 'minibuffer + :keymap read-passwd-map + :version "30.1" + + (setq read-passwd--hide-password nil + ;; Stolen from `eldoc-minibuffer-message'. + read-passwd--mode-line-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window)))) + + (if read-passwd-mode + (with-current-buffer read-passwd--mode-line-buffer + ;; Add `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format + (cons '(:eval read-passwd--mode-line-icon) + mode-line-format)))) + (with-current-buffer read-passwd--mode-line-buffer + ;; Remove `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format (cdr mode-line-format))))) + + (when read-passwd-mode + (read-passwd-toggle-visibility))) + +(defvar overriding-text-conversion-style) + +;;;###autoload +(defun read-passwd (prompt &optional confirm default) + "Read a password, prompting with PROMPT, and return it. +If optional CONFIRM is non-nil, read the password twice to make sure. +Optional DEFAULT is a default password to use instead of empty input. + +This function echoes `*' for each character that the user types. +You could let-bind `read-hide-char' to another hiding character, though. + +Once the caller uses the password, it can erase the password +by doing (clear-string STRING)." + (if confirm + (let (success) + (while (not success) + (let ((first (read-passwd prompt nil default)) + (second (read-passwd "Confirm password: " nil default))) + (if (equal first second) + (progn + (and (arrayp second) (not (eq first second)) (clear-string second)) + (setq success first)) + (and (arrayp first) (clear-string first)) + (and (arrayp second) (clear-string second)) + (message "Password not repeated accurately; please start over") + (sit-for 1)))) + success) + (let (minibuf) + (minibuffer-with-setup-hook + (lambda () + (setq minibuf (current-buffer)) + ;; Turn off electricity. + (setq-local post-self-insert-hook nil) + (setq-local buffer-undo-list t) + (setq-local select-active-regions nil) + (use-local-map read-passwd-map) + (setq-local inhibit-modification-hooks nil) ;bug#15501. + (setq-local show-paren-mode nil) ;bug#16091. + (setq-local inhibit--record-char t) + (read-passwd-mode 1) + (add-hook 'post-command-hook #'read-passwd--hide-password nil t)) + (unwind-protect + (let ((enable-recursive-minibuffers t) + (read-hide-char (or read-hide-char ?*)) + (overriding-text-conversion-style 'password)) + (read-string prompt nil t default)) ; t = "no history" + (when (buffer-live-p minibuf) + (with-current-buffer minibuf + (read-passwd-mode -1) + ;; Not sure why but it seems that there might be cases where the + ;; minibuffer is not always properly reset later on, so undo + ;; whatever we've done here (bug#11392). + (remove-hook 'after-change-functions + #'read-passwd--hide-password 'local) + (kill-local-variable 'post-self-insert-hook) + ;; And of course, don't keep the sensitive data around. + (erase-buffer) + ;; Then restore the previous text conversion style. + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style))))))))) + (provide 'auth-source) ;;; auth-source.el ends here diff --git a/lisp/bindings.el b/lisp/bindings.el index 4690897fed4..5a8c7cfafd7 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -381,7 +381,7 @@ the symbol `mode-line-format-right-align' is processed by `(space :align-to (,(- (window-pixel-width) (window-scroll-bar-width) (window-right-divider-width) - (* (or (cdr (window-margins)) 1) + (* (or (car (window-margins)) 0) (frame-char-width)) ;; Manually account for value of ;; `mode-line-right-align-edge' even @@ -803,6 +803,11 @@ meaningful if it refers to a lexically bound variable." '(menu-item "Flyspell (Fly)" flyspell-mode :help "Spell checking on the fly" :button (:toggle . (bound-and-true-p flyspell-mode)))) +(bindings--define-key mode-line-mode-menu [completion-preview-mode] + '(menu-item "Completion Preview (CP)" completion-preview-mode + :help "Show preview of completion suggestions as you type" + :enable completion-at-point-functions + :button (:toggle . (bound-and-true-p completion-preview-mode)))) (bindings--define-key mode-line-mode-menu [auto-revert-tail-mode] '(menu-item "Auto revert tail (Tail)" auto-revert-tail-mode :help "Revert the tail of the buffer when the file on disk grows" diff --git a/lisp/bookmark.el b/lisp/bookmark.el index bf2357207d8..06f8e24b518 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -515,18 +515,45 @@ See user option `bookmark-fringe-mark'." (non-essential t) overlays found temp) (when (and pos filename) - (setq filename (abbreviate-file-name (expand-file-name filename))) (dolist (buf (buffer-list)) (with-current-buffer buf - (when (equal filename - (ignore-errors (bookmark-buffer-file-name))) - (setq overlays - (save-excursion - (goto-char pos) - (overlays-in (pos-bol) (1+ (pos-bol))))) - (while (and (not found) (setq temp (pop overlays))) - (when (eq 'bookmark (overlay-get temp 'category)) - (delete-overlay (setq found temp)))))))))) + (let ((bkmk-fname (ignore-errors (bookmark-buffer-file-name)))) + (when bkmk-fname + ;; Normalize both filenames before comparing, because the + ;; filename we receive from the bookmark wasn't + ;; necessarily generated by `bookmark-buffer-file-name'. + ;; For example, bookmarks set in Info nodes get a filename + ;; based on `Info-current-file', and under certain + ;; circumstances that can be an unexpanded path (e.g., + ;; when the Info page was under your home directory). + (let ((this-fname-normalized (expand-file-name filename)) + (bkmk-fname-normalized (expand-file-name bkmk-fname))) + (when (equal this-fname-normalized bkmk-fname-normalized) + (setq overlays + (save-excursion + (save-restriction + ;; Suppose bookmark "foo" was earlier set at + ;; location X in a file, but now the file is + ;; narrowed such that X is outside the + ;; restriction. Then the `goto-char' below + ;; would go to the wrong place and thus the + ;; wrong overlays would be fetched. This is + ;; why we temporarily `widen' before + ;; fetching. + ;; + ;; (This circumstance can easily arise when + ;; a bookmark was set on Info node X but now + ;; the "*info*" buffer is showing some other + ;; node Y, with X and Y physically located + ;; in the same file, as is often the case + ;; with Info nodes. See bug #70019, for + ;; example.) + (widen) + (goto-char pos) + (overlays-in (pos-bol) (1+ (pos-bol)))))) + (while (and (not found) (setq temp (pop overlays))) + (when (eq 'bookmark (overlay-get temp 'category)) + (delete-overlay (setq found temp))))))))))))) (defun bookmark-maybe-sort-alist () "Return `bookmark-alist' for display. diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index ec5337e3fda..d59c5b6cf21 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -107,10 +107,10 @@ The default options can group by a mode, and by a root directory of a project or just `default-directory'. If this is nil, buffers are not divided into groups." :type '(choice (const :tag "No grouping" nil) - (function-item :tag "Group by mode" - Buffer-menu-group-by-mode) - (function-item :tag "Group by project root or directory" - Buffer-menu-group-by-root) + (const :tag "Group by mode" + Buffer-menu-group-by-mode) + (const :tag "Group by project root or directory" + Buffer-menu-group-by-root) (function :tag "Custom function")) :group 'Buffer-menu :version "30.1") @@ -798,7 +798,11 @@ See more at `Buffer-menu-filter-predicate'." (t ""))) (defun Buffer-menu-group-by-mode (entry) - (concat "* " (aref (cadr entry) 5))) + (let ((mode (aref (cadr entry) 5))) + (concat "* " (or (cdr (seq-find (lambda (group) + (string-match-p (car group) mode)) + mouse-buffer-menu-mode-groups)) + mode)))) (declare-function project-root "project" (project)) (defun Buffer-menu-group-by-root (entry) diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index d7e62e1baf3..95b04969075 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -895,8 +895,8 @@ it uses the current calendar date style." (save-match-data (cond ( ;; iso-style numeric date (string-match (concat "\\s-*" - "\\([0-9]\\{4\\}\\)[ \t/]\\s-*" - "0?\\([1-9][0-9]?\\)[ \t/]\\s-*" + "\\([0-9]\\{4\\}\\)[ \t/-]\\s-*" + "0?\\([1-9][0-9]?\\)[ \t/-]\\s-*" "0?\\([1-9][0-9]?\\)") datestring) (setq year (read (substring datestring (match-beginning 1) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index e96e2e7e2db..eca80f1e8b6 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -344,8 +344,11 @@ right of \"%x\", trailing zero units are not output." string) (cond ((string-equal spec "z") - (setq chop-leading (and leading-zeropos - (min leading-zeropos (match-beginning 0))))) + (setq chop-leading + (if leading-zeropos + (min leading-zeropos (match-beginning 0)) + ;; The entire spec is zero, get past "%z" to last 0. + (+ 2 (match-beginning 0))))) ((string-equal spec "x") (setq chop-trailing t)) (t diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el index 83ff451fa99..fda3edd602c 100644 --- a/lisp/cedet/data-debug.el +++ b/lisp/cedet/data-debug.el @@ -598,6 +598,29 @@ PREBUTTONTEXT is some text between prefix and the stuff vector button." ) ) +(defun data-debug-insert-stuff-record-button (stuffvector + prefix + prebuttontext) + "Insert a button representing STUFFVECTOR. +PREFIX is the text that precedes the button. +PREBUTTONTEXT is some text between prefix and the stuff vector button." + (let* ((start (point)) + (end nil) + (str (format "#<record o' stuff: %d entries>" (length stuffvector))) + (tip str)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) + (put-text-property start end 'ddebug stuffvector) + (put-text-property start end 'ddebug-indent (length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-stuff-vector-from-point) + (insert "\n") + ) + ) + ;;; Symbol ;; @@ -781,6 +804,9 @@ FACE is the face to use." ;; Vector of stuff (vectorp . data-debug-insert-stuff-vector-button) + + ;; Record of stuff + (recordp . data-debug-insert-stuff-record-button) ) "Alist of methods used to insert things into an Ddebug buffer.") diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 6d42c3125c0..920588abf89 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -928,6 +928,9 @@ but should be good enough for debugging assertions." (semanticdb-find-result-length result) (length result)))) +(cl-deftype semanticdb-find-result-with-nil () + '(satisfies semanticdb-find-result-with-nil-p)) + (defun semanticdb-find-result-with-nil-p (resultp) "Non-nil if RESULTP is in the form of a semanticdb search result. The value nil is valid where a TABLE usually is, but only if the TAG @@ -1307,19 +1310,25 @@ associated with that tag should be loaded into a buffer." "In TABLE, find all occurrences of tags with NAME. Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." - (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-by-name name + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (cl-defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) "In TABLE, find all occurrences of tags matching REGEXP. Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." - (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-by-name-regexp regexp + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (cl-defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) "In TABLE, find all occurrences of tags matching PREFIX. Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." - (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-for-completion prefix + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (cl-defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags) "In TABLE, find all occurrences of tags of CLASS. @@ -1329,8 +1338,12 @@ Returns a table of all matching tags." ;; `semantic-find-tags-included', which by default will just call ;; `semantic-find-tags-by-class'. (if (eq class 'include) - (semantic-find-tags-included (or tags (semanticdb-get-tags table))) - (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-included + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))) + (semantic-find-tags-by-class class + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (declare-function semantic-find-tags-external-children-of-type "semantic/find" (type &optional table)) @@ -1340,7 +1353,9 @@ Returns a table of all matching tags." Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." (require 'semantic/find) - (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-external-children-of-type + parent (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (declare-function semantic-find-tags-subclasses-of-type "semantic/find" (type &optional table)) @@ -1350,7 +1365,9 @@ Returns a table of all matching tags." Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." (require 'semantic/find) - (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-subclasses-of-type + parent (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) ;;; Deep Searches (cl-defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) @@ -1359,7 +1376,10 @@ Search in all tags in TABLE, and all components of top level tags in TABLE. Optional argument TAGS is a list of tags to search. Return a table of all matching tags." - (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-by-name + name (semantic-flatten-tags-table + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) "In TABLE, find all occurrences of tags matching REGEXP. @@ -1367,7 +1387,10 @@ Search in all tags in TABLE, and all components of top level tags in TABLE. Optional argument TAGS is a list of tags to search. Return a table of all matching tags." - (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-by-name-regexp + regexp (semantic-flatten-tags-table + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (cl-defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) "In TABLE, find all occurrences of tags matching PREFIX. @@ -1375,7 +1398,11 @@ Search in all tags in TABLE, and all components of top level tags in TABLE. Optional argument TAGS is a list of tags to search. Return a table of all matching tags." - (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-for-completion + prefix + (semantic-flatten-tags-table + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (provide 'semantic/db-find) diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el index 41030aa6944..db6b3988562 100644 --- a/lisp/cedet/srecode/find.el +++ b/lisp/cedet/srecode/find.el @@ -233,8 +233,8 @@ templates." (when (or (not predicate) (funcall predicate temp)) (puthash key temp mhash))) - (oref tab namehash)))) - mhash)))) + (oref tab namehash)))))) + mhash)) (defun srecode-calculate-default-template-string (hash) "Calculate the name of the template to use as a DEFAULT. diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index c84a1809322..d4316fb1175 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -238,7 +238,8 @@ is run). (inferior-scheme-mode))) (setq scheme-program-name cmd) (setq scheme-buffer "*scheme*") - (pop-to-buffer "*scheme*" display-comint-buffer-action)) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer "*scheme*" display-comint-buffer-action))) (defun scheme-start-file (prog) "Return the name of the start file corresponding to PROG. @@ -358,7 +359,8 @@ With argument, position cursor at end of buffer." (interactive "P") (if (or (and scheme-buffer (get-buffer scheme-buffer)) (scheme-interactively-start-process)) - (pop-to-buffer scheme-buffer display-comint-buffer-action) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer scheme-buffer display-comint-buffer-action)) (error "No current process buffer. See variable `scheme-buffer'")) (when eob-p (push-mark) diff --git a/lisp/comint.el b/lisp/comint.el index a8fe095e99c..e856038b0f7 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -3961,18 +3961,22 @@ REGEXP-GROUP is the regular expression group in REGEXP to use." ;;; OSC escape sequences (Operating System Commands) ;;============================================================================ ;; Adding `comint-osc-process-output' to -;; `comint-output-filter-functions' enables the interpretation of OSC -;; escape sequences. By default, OSC 7 and 8 (for current directory -;; and hyperlinks respectively) are acted upon. Adding more entries -;; to `comint-osc-handlers' allows a customized treatment of further -;; sequences. +;; `comint-output-filter-functions' enables interpreting of OSC +;; escape sequences. See `ansi-osc-handlers' for a list of OSC +;; sequences which are interpreted by default and information on how to +;; handle new sequences. ;; Aliases defined for reverse compatibility -(defvaralias 'comint-osc-handlers 'ansi-osc-handlers) -(defalias 'comint-osc-directory-tracker 'ansi-osc-directory-tracker) -(defalias 'comint-osc-hyperlink-handler 'ansi-osc-hyperlink-handler) -(defalias 'comint-osc-hyperlink 'ansi-osc-hyperlink) -(defvaralias 'comint-osc-hyperlink-map 'ansi-osc-hyperlink-map) +(define-obsolete-variable-alias + 'comint-osc-handlers 'ansi-osc-handlers "30.1") +(define-obsolete-function-alias + 'comint-osc-directory-tracker 'ansi-osc-directory-tracker "30.1") +(define-obsolete-function-alias + 'comint-osc-hyperlink-handler 'ansi-osc-hyperlink-handler "30.1") +(define-obsolete-function-alias + 'comint-osc-hyperlink 'ansi-osc-hyperlink "30.1") +(define-obsolete-variable-alias + 'comint-osc-hyperlink-map 'ansi-osc-hyperlink-map "30.1") (defun comint-osc-process-output (_) "Interpret OSC escape sequences in comint output. @@ -3985,7 +3989,7 @@ sequences of the forms Specifically, every occurrence of such escape sequences is removed from the buffer. Then, if `command' is a key of the -`comint-osc-handlers' alist, the corresponding value, which +`ansi-osc-handlers' alist, the corresponding value, which should be a function, is called with `command' and `text' as arguments, with point where the escape sequence was located." (let ((start (1- comint-last-output-start)) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index e827da43a08..e2012b0f80a 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -39,6 +39,16 @@ ;; example, to M-n and M-p in `completion-preview-active-mode-map' to ;; have them handy whenever the preview is visible. ;; +;; When the completion candidate that the preview is showing shares a +;; common prefix with all other candidates, Completion Preview mode +;; underlines that common prefix. If you want to insert the common +;; prefix but with a different suffix than the one the preview is +;; showing, use the command `completion-preview-complete'. This command +;; inserts just the common prefix and lets you go on typing as usual. +;; If you invoke `completion-preview-complete' when there is no common +;; prefix (so nothing is underlined in the preview), it displays a list +;; of all matching completion candidates. +;; ;; If you set the user option `completion-preview-exact-match-only' to ;; non-nil, Completion Preview mode only suggests a completion ;; candidate when its the only possible completion for the (partial) @@ -52,8 +62,6 @@ ;;; Code: -(require 'mwheel) - (defgroup completion-preview nil "In-buffer completion preview." :group 'completion) @@ -75,7 +83,8 @@ first candidate, and you can cycle between the candidates with insert-char delete-backward-char backward-delete-char-untabify - analyze-text-conversion) + analyze-text-conversion + completion-preview-complete) "List of commands that should trigger completion preview." :type '(repeat (function :tag "Command" :value self-insert-command)) :version "30.1") @@ -106,16 +115,22 @@ If this option is nil, these commands do not display any message." (defface completion-preview '((t :inherit shadow)) - "Face for completion preview overlay." + "Face for completion candidates in the completion preview overlay." :version "30.1") -(defface completion-preview-exact +(defface completion-preview-common '((((supports :underline t)) :underline t :inherit completion-preview) (((supports :weight bold)) :weight bold :inherit completion-preview) (t :background "gray")) - "Face for exact completion preview overlay." + "Face for the longest common prefix in the completion preview." + :version "30.1") + +(defface completion-preview-exact + ;; An exact match is also the longest common prefix of all matches. + '((t :underline "gray25" :inherit completion-preview-common)) + "Face for matches in the completion preview overlay." :version "30.1") (defface completion-preview-highlight @@ -126,43 +141,56 @@ If this option is nil, these commands do not display any message." (defvar-keymap completion-preview-active-mode-map :doc "Keymap for Completion Preview Active mode." "C-i" #'completion-preview-insert + ;; FIXME: Should this have another/better binding by default? + "M-i" #'completion-preview-complete ;; "M-n" #'completion-preview-next-candidate ;; "M-p" #'completion-preview-prev-candidate ) +(defun completion-preview--ignore () + "Do nothing, including updating the completion preview. + +This is the same as `ignore', except that Completion Preview mode skips +hiding or updating the completion preview after this command runs." + (interactive) + nil) + +(put 'completion-preview--ignore 'completion-predicate #'ignore) + (defvar-keymap completion-preview--mouse-map :doc "Keymap for mouse clicks on the completion preview." - "<down-mouse-1>" #'completion-preview-insert - "C-<down-mouse-1>" #'completion-at-point - "<down-mouse-2>" #'completion-at-point - ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events - ;; and vice versa!! - "<wheel-up>" #'completion-preview-prev-candidate - "<wheel-down>" #'completion-preview-next-candidate - (key-description (vector mouse-wheel-up-event)) - #'completion-preview-next-candidate - (key-description (vector mouse-wheel-down-event)) - #'completion-preview-prev-candidate) + "<mouse-1>" #'completion-preview-insert + ;; Ignore the corresponding button-down event. + "<down-mouse-1>" #'completion-preview--ignore + "C-<mouse-1>" #'completion-preview-complete + "C-<down-mouse-1>" #'completion-preview--ignore + "<mouse-2>" #'completion-preview-complete + "<down-mouse-2>" #'completion-preview--ignore + "<wheel-up>" #'completion-preview-prev-candidate + "<wheel-down>" #'completion-preview-next-candidate) (defvar-local completion-preview--overlay nil) (defvar completion-preview--internal-commands '(completion-preview-next-candidate completion-preview-prev-candidate + completion-preview--ignore ;; Don't dismiss or update the preview when the user scrolls. mwheel-scroll) "List of commands that manipulate the completion preview. Completion Preview mode avoids updating the preview after these commands.") -(defsubst completion-preview--internal-command-p () - "Return non-nil if `this-command' manipulates the completion preview." - (memq this-command completion-preview--internal-commands)) +(defvar-local completion-preview--inhibit-update-p nil + "Whether to inhibit updating the completion preview following this command.") + +(defsubst completion-preview--inhibit-update () + "Inhibit updating the completion preview following this command." + (setq completion-preview--inhibit-update-p t)) (defsubst completion-preview-require-certain-commands () "Check if `this-command' is one of `completion-preview-commands'." - (or (completion-preview--internal-command-p) - (memq this-command completion-preview-commands))) + (memq this-command completion-preview-commands)) (defun completion-preview-require-minimum-symbol-length () "Check if the length of symbol at point is at least above a certain threshold. @@ -175,7 +203,8 @@ Completion Preview mode avoids updating the preview after these commands.") "Hide the completion preview." (when completion-preview--overlay (delete-overlay completion-preview--overlay) - (setq completion-preview--overlay nil))) + (setq completion-preview--overlay nil + completion-preview--inhibit-update-p nil))) (defun completion-preview--make-overlay (pos string) "Make preview overlay showing STRING at POS, or move existing preview there." @@ -183,13 +212,9 @@ Completion Preview mode avoids updating the preview after these commands.") (move-overlay completion-preview--overlay pos pos) (setq completion-preview--overlay (make-overlay pos pos)) (overlay-put completion-preview--overlay 'window (selected-window))) - (let ((previous (overlay-get completion-preview--overlay 'after-string))) - (unless (and previous (string= previous string) - (eq (get-text-property 0 'face previous) - (get-text-property 0 'face string))) - (add-text-properties 0 1 '(cursor 1) string) - (overlay-put completion-preview--overlay 'after-string string)) - completion-preview--overlay)) + (add-text-properties 0 1 '(cursor 1) string) + (overlay-put completion-preview--overlay 'after-string string) + completion-preview--overlay) (defsubst completion-preview--get (prop) "Return property PROP of the completion preview overlay." @@ -214,29 +239,50 @@ Completion Preview mode adds this function to #'completion-preview--window-selection-change t) (completion-preview-hide))) +(defvar completion-preview-completion-styles '(basic) + "List of completion styles that Completion Preview mode uses. + +Since Completion Preview mode shows prefix completion candidates, this +list should normally only include completion styles that perform prefix +completion, but other candidates are filtered out and cause no harm. + +See also `completion-styles'.") + (defun completion-preview--try-table (table beg end props) "Check TABLE for a completion matching the text between BEG and END. PROPS is a property list with additional information about TABLE. See `completion-at-point-functions' for more details. -If TABLE contains a matching completion, return a list -\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to -show in the completion preview, ALL is the list of all matching -completion candidates, BASE is a common prefix that TABLE elided -from the start of each candidate, and EXIT-FN is either a -function to call after inserting PREVIEW or nil. If TABLE does -not contain matching completions, or if there are multiple -matching completions and `completion-preview-exact-match-only' is -non-nil, return nil instead." +If TABLE contains a matching candidate, return a list +\(BASE COMMON SUFFIXES) where BASE is a prefix of the text +between BEG and END that TABLE elided from the start of each candidate, +COMMON is the longest common prefix of all matching candidates, +SUFFIXES is a list of different suffixes that together with COMMON yield +the matching candidates. If TABLE does not contain matching +candidates or if there are multiple matching completions and +`completion-preview-exact-match-only' is non-nil, return nil instead." + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;; + ;; | buffer text | preview | ;; + ;; | | | ;; + ;; beg end | ;; + ;; |------+------|--+--------| Each of base, common and suffix ;; + ;; | base | common | suffix | <- may be empty, except common and ;; + ;; suffix cannot both be empty. ;; + ;; ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((pred (plist-get props :predicate)) - (exit-fn (plist-get props :exit-function)) (string (buffer-substring beg end)) (md (completion-metadata string table pred)) (sort-fn (or (completion-metadata-get md 'cycle-sort-function) (completion-metadata-get md 'display-sort-function) completion-preview-sort-function)) - (all (let ((completion-lazy-hilit t)) + (all (let ((completion-lazy-hilit t) + ;; FIXME: This does not override styles prescribed + ;; by the completion category via + ;; e.g. `completion-category-defaults'. + (completion-styles completion-preview-completion-styles)) (completion-all-completions string table pred (- (point) beg) md))) (last (last all)) @@ -245,16 +291,16 @@ non-nil, return nil instead." (when last (setcdr last nil) (when-let ((sorted (funcall sort-fn - (delete prefix (all-completions prefix all))))) - (unless (and (cdr sorted) completion-preview-exact-match-only) - (list (propertize (substring (car sorted) (length prefix)) - 'face (if (cdr sorted) - 'completion-preview - 'completion-preview-exact) - 'mouse-face 'completion-preview-highlight - 'keymap completion-preview--mouse-map) - (+ beg base) end sorted - (substring string 0 base) exit-fn)))))) + (delete prefix (all-completions prefix all)))) + (common (try-completion prefix sorted)) + (lencom (length common)) + (suffixes sorted)) + (unless (and (cdr suffixes) completion-preview-exact-match-only) + ;; Remove the common prefix from each candidate. + (while sorted + (setcar sorted (substring (car sorted) lencom)) + (setq sorted (cdr sorted))) + (list (substring string 0 base) common suffixes)))))) (defun completion-preview--capf-wrapper (capf) "Translate return value of CAPF to properties for completion preview overlay." @@ -262,25 +308,41 @@ non-nil, return nil instead." (and (consp res) (not (functionp res)) (seq-let (beg end table &rest plist) res - (or (completion-preview--try-table table beg end plist) + (or (when-let ((data (completion-preview--try-table + table beg end plist))) + `(,(+ beg (length (car data))) ,end ,plist ,@data)) (unless (eq 'no (plist-get plist :exclusive)) ;; Return non-nil to exclude other capfs. '(nil))))))) (defun completion-preview--update () "Update completion preview." - (seq-let (preview beg end all base exit-fn) + (seq-let (beg end props base common suffixes) (run-hook-wrapped 'completion-at-point-functions #'completion-preview--capf-wrapper) - (when preview - (let ((ov (completion-preview--make-overlay end preview))) + (when-let ((suffix (car suffixes))) + (set-text-properties 0 (length suffix) + (list 'face (if (cdr suffixes) + 'completion-preview + 'completion-preview-exact)) + suffix) + (set-text-properties 0 (length common) + (list 'face (if (cdr suffixes) + 'completion-preview-common + 'completion-preview-exact)) + common) + (let ((ov (completion-preview--make-overlay + end (propertize (concat (substring common (- end beg)) suffix) + 'mouse-face 'completion-preview-highlight + 'keymap completion-preview--mouse-map)))) (overlay-put ov 'completion-preview-beg beg) (overlay-put ov 'completion-preview-end end) (overlay-put ov 'completion-preview-index 0) - (overlay-put ov 'completion-preview-cands all) + (overlay-put ov 'completion-preview-suffixes suffixes) + (overlay-put ov 'completion-preview-common common) (overlay-put ov 'completion-preview-base base) - (overlay-put ov 'completion-preview-exit-fn exit-fn) + (overlay-put ov 'completion-preview-props props) (completion-preview-active-mode))))) (defun completion-preview--show () @@ -303,17 +365,22 @@ point, otherwise hide it." ;; flicker, even with slow completion backends. (let* ((beg (completion-preview--get 'completion-preview-beg)) (end (max (point) (overlay-start completion-preview--overlay))) - (cands (completion-preview--get 'completion-preview-cands)) + (sufs (completion-preview--get 'completion-preview-suffixes)) (index (completion-preview--get 'completion-preview-index)) - (cand (nth index cands)) - (after (completion-preview--get 'after-string)) - (face (get-text-property 0 'face after))) + (common (completion-preview--get 'completion-preview-common)) + (suffix (nth index sufs)) + (cand nil)) + (set-text-properties 0 (length suffix) + (list 'face (if (cdr sufs) + 'completion-preview + 'completion-preview-exact)) + suffix) + (setq cand (concat common (nth index sufs))) (if (and (<= beg (point) end (1- (+ beg (length cand)))) (string-prefix-p (buffer-substring beg end) cand)) ;; The previous preview is still applicable, update it. (overlay-put (completion-preview--make-overlay end (propertize (substring cand (- end beg)) - 'face face 'mouse-face 'completion-preview-highlight 'keymap completion-preview--mouse-map)) 'completion-preview-end end) @@ -324,16 +391,18 @@ point, otherwise hide it." (defun completion-preview--post-command () "Create, update or delete completion preview post last command." - (if (and (completion-preview-require-certain-commands) - (completion-preview-require-minimum-symbol-length)) - ;; We should show the preview. - (or - ;; If we're called after a command that itself updates the - ;; preview, don't do anything. - (completion-preview--internal-command-p) - ;; Otherwise, show the preview. - (completion-preview--show)) - (completion-preview-active-mode -1))) + (let ((internal-p (or completion-preview--inhibit-update-p + (memq this-command + completion-preview--internal-commands)))) + (setq completion-preview--inhibit-update-p nil) + + ;; If we're called after a command that itself updates the + ;; preview, don't do anything. + (unless internal-p + (if (and (completion-preview-require-certain-commands) + (completion-preview-require-minimum-symbol-length)) + (completion-preview--show) + (completion-preview-active-mode -1))))) (defun completion-preview-insert () "Insert the completion candidate that the preview is showing." @@ -342,43 +411,124 @@ point, otherwise hide it." (let* ((pre (completion-preview--get 'completion-preview-base)) (end (completion-preview--get 'completion-preview-end)) (ind (completion-preview--get 'completion-preview-index)) - (all (completion-preview--get 'completion-preview-cands)) - (efn (completion-preview--get 'completion-preview-exit-fn)) + (all (completion-preview--get 'completion-preview-suffixes)) + (com (completion-preview--get 'completion-preview-common)) + (efn (plist-get (completion-preview--get 'completion-preview-props) + :exit-function)) (aft (completion-preview--get 'after-string)) - (str (concat pre (nth ind all)))) + (str (concat pre com (nth ind all)))) (completion-preview-active-mode -1) (goto-char end) (insert (substring-no-properties aft)) (when (functionp efn) (funcall efn str 'finished))) (user-error "No current completion preview"))) -(defun completion-preview-prev-candidate () - "Cycle the candidate that the preview is showing to the previous suggestion." +(defun completion-preview-complete () + "Complete up to the longest common prefix of all completion candidates. + +If you call this command twice in a row, or otherwise if there is no +common prefix to insert, it displays the list of matching completion +candidates unless `completion-auto-help' is nil. If you repeat this +command again when the completions list is visible, it scrolls the +completions list." (interactive) - (completion-preview-next-candidate -1)) + (unless completion-preview-active-mode + (user-error "No current completion preview")) + (let* ((beg (completion-preview--get 'completion-preview-beg)) + (end (completion-preview--get 'completion-preview-end)) + (com (completion-preview--get 'completion-preview-common)) + (cur (completion-preview--get 'completion-preview-index)) + (all (completion-preview--get 'completion-preview-suffixes)) + (base (completion-preview--get 'completion-preview-base)) + (props (completion-preview--get 'completion-preview-props)) + (efn (plist-get props :exit-function)) + (ins (substring-no-properties com (- end beg)))) + (goto-char end) + (if (string-empty-p ins) + ;; If there's nothing to insert, call `completion-at-point' to + ;; show the completions list (or just display a message when + ;; `completion-auto-help' is nil). + (let* ((completion-styles completion-preview-completion-styles) + (sub (substring-no-properties com)) + (col (mapcar (lambda (suf) + (concat sub (substring-no-properties suf))) + (append (nthcdr cur all) (take cur all)))) + ;; The candidates are already in order. + (props (plist-put props :display-sort-function #'identity)) + ;; The :exit-function might be slow, e.g. when the + ;; backend is Eglot, so we ensure that the preview is + ;; hidden before any original :exit-function is called. + (props (plist-put props :exit-function + (when (functionp efn) + (lambda (string status) + (completion-preview-active-mode -1) + (funcall efn string status))))) + ;; The predicate is meant for the original completion + ;; candidates, which may be symbols or cons cells, but + ;; now we only have strings, so it might be unapplicable. + (props (plist-put props :predicate nil)) + (completion-at-point-functions + (list (lambda () `(,beg ,end ,col ,@props))))) + (completion-preview--inhibit-update) + (completion-at-point)) + ;; Otherwise, insert the common prefix and update the preview. + (insert ins) + (let ((suf (nth cur all)) + (pos (point))) + (if (or (string-empty-p suf) (null suf)) + ;; If we've inserted a full candidate, let the post-command + ;; hook update the completion preview in case the candidate + ;; can be completed further. + (when (functionp efn) + (funcall efn (concat base com) (if (cdr all) 'exact 'finished))) + ;; Otherwise, remove the common prefix from the preview. + (completion-preview--inhibit-update) + (overlay-put (completion-preview--make-overlay + pos (propertize + suf 'mouse-face 'completion-preview-highlight + 'keymap completion-preview--mouse-map)) + 'completion-preview-end pos)))))) -(defun completion-preview-next-candidate (direction) - "Cycle the candidate that the preview is showing in direction DIRECTION. +(defun completion-preview-prev-candidate (n) + "Cycle the candidate the preview is showing N candidates backward. -DIRECTION should be either 1 which means cycle forward, or -1 -which means cycle backward. Interactively, DIRECTION is the +If N is negative, cycle -N candidates forward. Interactively, N is the +prefix argument and defaults to 1." + (interactive "p") + (completion-preview-next-candidate (- n))) + +(defun completion-preview-next-candidate (n) + "Cycle the candidate the preview is showing N candidates forward. + +If N is negative, cycle -N candidates backward. Interactively, N is the prefix argument and defaults to 1." (interactive "p") (when completion-preview-active-mode (let* ((beg (completion-preview--get 'completion-preview-beg)) (end (completion-preview--get 'completion-preview-end)) - (all (completion-preview--get 'completion-preview-cands)) + (all (completion-preview--get 'completion-preview-suffixes)) + (com (completion-preview--get 'completion-preview-common)) (cur (completion-preview--get 'completion-preview-index)) (len (length all)) - (new (mod (+ cur direction) len)) - (str (nth new all))) - (while (or (<= (+ beg (length str)) end) - (not (string-prefix-p (buffer-substring beg end) str))) - (setq new (mod (+ new direction) len) str (nth new all))) - (let ((aft (propertize (substring str (- end beg)) - 'face (if (< 1 len) - 'completion-preview - 'completion-preview-exact) + (new (mod (+ cur n) len)) + (suf (nth new all)) + (lencom (length com))) + ;; Skip suffixes that are no longer applicable. This may happen + ;; when the user continues typing and immediately runs this + ;; command, before the completion backend returns an updated set + ;; of completions for the new (longer) prefix, so we still have + ;; the previous (larger) set of candidates at hand. + (while (or (<= (+ beg lencom (length suf)) end) + (not (string-prefix-p (buffer-substring beg end) + (concat com suf)))) + (setq new (mod (+ new n) len) + suf (nth new all))) + (set-text-properties 0 (length suf) + (list 'face (if (cdr all) + 'completion-preview + 'completion-preview-exact)) + suf) + (let ((aft (propertize (substring (concat com suf) (- end beg)) 'mouse-face 'completion-preview-highlight 'keymap completion-preview--mouse-map))) (add-text-properties 0 1 '(cursor 1) aft) @@ -393,6 +543,7 @@ prefix argument and defaults to 1." (buffer-local-value 'completion-preview-active-mode buffer)) (dolist (cmd '(completion-preview-insert + completion-preview-complete completion-preview-prev-candidate completion-preview-next-candidate)) (put cmd 'completion-predicate #'completion-preview--active-p)) @@ -404,16 +555,29 @@ prefix argument and defaults to 1." This mode automatically shows and updates the completion preview according to the text around point. \\<completion-preview-active-mode-map>\ -When the preview is visible, \\[completion-preview-insert] -accepts the completion suggestion, +When the preview is visible, \\[completion-preview-insert] accepts the +completion suggestion, \\[completion-preview-complete] completes up to +the longest common prefix of all completion candidates, \\[completion-preview-next-candidate] cycles forward to the next -completion suggestion, and \\[completion-preview-prev-candidate] -cycles backward." +completion suggestion, and \\[completion-preview-prev-candidate] cycles +backward." :lighter " CP" (if completion-preview-mode (add-hook 'post-command-hook #'completion-preview--post-command nil t) (remove-hook 'post-command-hook #'completion-preview--post-command t) (completion-preview-active-mode -1))) +;;;###autoload +(define-globalized-minor-mode global-completion-preview-mode + completion-preview-mode completion-preview-mode + :predicate '((not compilation-mode + diff-mode + dired-mode + minibuffer-mode + minibuffer-inactive-mode + special-mode + wdired-mode) + t)) + (provide 'completion-preview) ;;; completion-preview.el ends here diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index f004002333b..2c1ba9bb9d7 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -2251,24 +2251,33 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk android) (class color) + (min-colors 88)) ; Like default mode line :box (:line-width 2 :style released-button) - :background "lightgrey" :foreground "black")) + :background "lightgrey" :foreground "black") + (((type x w32 ns haiku pgtk android)) + :box (:line-width 2 :style released-button) + :background "white" :foreground "black")) "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." - :version "21.1" + :version "30.1" :group 'custom-faces) (defface custom-button-mouse - '((((type x w32 ns haiku pgtk android) (class color)) + '((((type x w32 ns haiku pgtk android) (class color) + (min-colors 88)) :box (:line-width 2 :style released-button) :background "grey90" :foreground "black") + (((type x w32 ns haiku pgtk android)) + :box (:line-width 2 :style released-button) + ;; Either light gray or a stipple pattern. + :background "gray20" :foreground "black") (t ;; This is for text terminals that support mouse, like GPM mouse ;; or the MS-DOS terminal: inverse-video makes the button stand ;; out on mouse-over. :inverse-video t)) "Mouse face for custom buffer buttons if `custom-raised-buttons' is non-nil." - :version "22.1" + :version "30.1" :group 'custom-faces) (defface custom-button-unraised @@ -2284,12 +2293,16 @@ and `face'." (if custom-raised-buttons 'custom-button-mouse 'highlight)) (defface custom-button-pressed - '((((type x w32 ns haiku pgtk android) (class color)) + '((((type x w32 ns haiku pgtk android) (class color grayscale)) :box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black") + (((type x w32 ns haiku pgtk android)) + :box (:line-width 2 :style pressed-button) + ;; Either light gray or a stipple pattern. + :background "gray20" :foreground "black") (t :inverse-video t)) "Face for pressed custom buttons if `custom-raised-buttons' is non-nil." - :version "21.1" + :version "30.1" :group 'custom-faces) (defface custom-button-pressed-unraised @@ -4958,6 +4971,8 @@ if only the first line of the docstring is shown.")) ;; readably. (Bug#52554) (print-escape-control-characters t)) (atomic-change-group + (when (eobp) + (insert ";;; -*- lexical-binding: t -*-\n")) (custom-save-variables) (custom-save-faces) (custom-save-icons))) @@ -5350,6 +5365,12 @@ If several parents are listed, go to the first of them." (setq-local widget-link-suffix "")) (setq show-trailing-whitespace nil)) +(defvar touch-screen-keyboard-function) ; In touch-screen.el. + +(defun Custom-display-on-screen-keyboard-p () + "Return whether it is okay to display the virtual keyboard at point." + (get-char-property (point) 'field)) + (define-derived-mode Custom-mode nil "Custom" "Major mode for editing customization buffers. @@ -5387,6 +5408,9 @@ if that value is non-nil." (setq-local custom--invocation-options nil custom--hidden-state 'hidden) (setq-local revert-buffer-function #'custom--revert-buffer) + (setq-local text-conversion-style 'action) + (setq-local touch-screen-keyboard-function + #'Custom-display-on-screen-keyboard-p) (make-local-variable 'custom-options) (make-local-variable 'custom-local-buffer) (custom--initialize-widget-variables) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 47afa841f5e..d0a1a66e29f 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -141,7 +141,10 @@ (const :format "" :value :style) (choice :tag "Style" (const :tag "Line" line) - (const :tag "Wave" wave)) + (const :tag "Double line" double-line) + (const :tag "Wave" wave) + (const :tag "Dots" dots) + (const :tag "Dashes" dashes)) (const :format "" :value :position) (choice :tag "Position" (const :tag "At Default Position" nil) diff --git a/lisp/custom.el b/lisp/custom.el index a19b14aaf8a..6f2aa18ba1d 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -667,7 +667,8 @@ If NOSET is non-nil, don't bother autoloading LOAD when setting the variable." A customizable variable is either (i) a variable whose property list contains a non-nil `standard-value' or `custom-autoload' property, or (ii) an alias for another customizable variable." - (declare (side-effect-free t)) + (declare (type (function (symbol) t)) + (side-effect-free t)) (when (symbolp variable) (setq variable (indirect-variable variable)) (or (get variable 'standard-value) diff --git a/lisp/dframe.el b/lisp/dframe.el index 4031e0784c2..8e664c0204a 100644 --- a/lisp/dframe.el +++ b/lisp/dframe.el @@ -684,6 +684,8 @@ Must be bound to event E." (sit-for 0) (popup-menu (mouse-menu-major-mode-map) e))) +(put 'dframe-popup-kludge 'mouse-1-menu-command t) + ;;; Interactive user functions for the mouse ;; (defun dframe-mouse-event-p (event) diff --git a/lisp/dired.el b/lisp/dired.el index 9e3b888df14..28ec187e666 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1740,8 +1740,16 @@ see `dired-use-ls-dired' for more details.") (file-expand-wildcards (cdr dir-wildcard)))) (let ((beg (point))) (insert-directory f switches nil nil) - ;; Re-align fields, if necessary. - (dired-align-file beg (point)))))) + ;; `dired-align-file' doesn't fare well with dired + ;; implementations that don't indent entries by one + ;; column, which in all known implementations is + ;; equivalent to not supporting `--dired'. + (save-excursion + (goto-char beg) + (unless (looking-at " ") + (insert " "))) + ;; Re-align fields, if necessary. + (dired-align-file beg (point)))))) (t (insert-directory dir switches wildcard (not wildcard)))) ;; Quote certain characters, unless ls quoted them for us. @@ -2743,6 +2751,26 @@ Keybindings: '(dired-font-lock-keywords t nil nil beginning-of-line)) (setq-local desktop-save-buffer 'dired-desktop-buffer-misc-data) (setq-local grep-read-files-function #'dired-grep-read-files) + (setq-local window-point-context-set-function + (lambda (w) + (with-current-buffer (window-buffer w) + (let ((point (window-point w))) + (save-excursion + (goto-char point) + (if-let ((f (dired-get-filename nil t))) + `((dired-filename . ,f)) + `((position . ,(point))))))))) + (setq-local window-point-context-use-function + (lambda (w context) + (with-current-buffer (window-buffer w) + (let ((point (window-point w))) + (save-excursion + (if-let ((f (alist-get 'dired-filename context))) + (dired-goto-file f) + (when-let ((p (alist-get 'position context))) + (goto-char p))) + (setq point (point))) + (set-window-point w point))))) (setq dired-switches-alist nil) (hack-dir-local-variables-non-file-buffer) ; before sorting (dired-sort-other dired-actual-switches t) diff --git a/lisp/dnd.el b/lisp/dnd.el index 1fc1ab45b84..411f0d5774c 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -151,8 +151,13 @@ Windows." (with-selected-window window (scroll-down 1)))))))) (when dnd-indicate-insertion-point - (ignore-errors - (goto-char (posn-point posn))))))) + (let ((pos (posn-point posn))) + ;; We avoid errors here, since on some systems this runs + ;; when waiting_for_input is non-zero, and that aborts on + ;; error. + (if (and pos (<= (point-min) pos (point-max))) + (goto-char pos) + pos)))))) (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. diff --git a/lisp/doc-view.el b/lisp/doc-view.el index c4b384c35c6..4ae9a5e6629 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -2092,35 +2092,35 @@ GOTO-PAGE-FN other than `doc-view-goto-page'." (defun doc-view-set-doc-type () "Figure out the current document type (`doc-view-doc-type')." (let ((name-types - (when buffer-file-name - (cdr (assoc-string - (file-name-extension buffer-file-name) - '( - ;; DVI - ("dvi" dvi) - ;; PDF - ("pdf" pdf) ("epdf" pdf) - ;; EPUB - ("epub" epub) - ;; PostScript - ("ps" ps) ("eps" ps) - ;; DjVu - ("djvu" djvu) - ;; OpenDocument formats. - ("odt" odf) ("ods" odf) ("odp" odf) ("odg" odf) - ("odc" odf) ("odi" odf) ("odm" odf) ("ott" odf) - ("ots" odf) ("otp" odf) ("otg" odf) - ;; Microsoft Office formats (also handled by the odf - ;; conversion chain). - ("doc" odf) ("docx" odf) ("xls" odf) ("xlsx" odf) - ("ppt" odf) ("pps" odf) ("pptx" odf) ("rtf" odf) - ;; CBZ - ("cbz" cbz) - ;; FB2 - ("fb2" fb2) - ;; (Open)XPS - ("xps" xps) ("oxps" oxps)) - t)))) + (cdr (assoc-string + (file-name-extension + (or buffer-file-name (buffer-name (current-buffer)))) + '( + ;; DVI + ("dvi" dvi) + ;; PDF + ("pdf" pdf) ("epdf" pdf) + ;; EPUB + ("epub" epub) + ;; PostScript + ("ps" ps) ("eps" ps) + ;; DjVu + ("djvu" djvu) + ;; OpenDocument formats. + ("odt" odf) ("ods" odf) ("odp" odf) ("odg" odf) + ("odc" odf) ("odi" odf) ("odm" odf) ("ott" odf) + ("ots" odf) ("otp" odf) ("otg" odf) + ;; Microsoft Office formats (also handled by the odf + ;; conversion chain). + ("doc" odf) ("docx" odf) ("xls" odf) ("xlsx" odf) + ("ppt" odf) ("pps" odf) ("pptx" odf) ("rtf" odf) + ;; CBZ + ("cbz" cbz) + ;; FB2 + ("fb2" fb2) + ;; (Open)XPS + ("xps" xps) ("oxps" oxps)) + t))) (content-types (save-excursion (goto-char (point-min)) diff --git a/lisp/edmacro.el b/lisp/edmacro.el index abfc380d154..c63f7f30c5e 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -460,8 +460,8 @@ of a line, that final line is excluded." (goto-char final-position))) (defun edmacro-mode () - "\\<edmacro-mode-map>Keyboard Macro Editing mode. Press \ -\\[edmacro-finish-edit] to save and exit. + "Keyboard Macro Editing mode. +\\<edmacro-mode-map>Press \\[edmacro-finish-edit] to save and exit. To abort the edit, just kill this buffer with \\[kill-buffer] \\`RET'. Press \\[edmacro-insert-key] to insert the name of any key by typing the key. @@ -744,9 +744,13 @@ This function assumes that the events can be stored in a string." ;; info is recorded in macros to make this possible. ((or (mouse-event-p ev) (mouse-movement-p ev) (memq (event-basic-type ev) - `( ,mouse-wheel-down-event ,mouse-wheel-up-event - ,mouse-wheel-right-event ,mouse-wheel-left-event - wheel-down wheel-up wheel-left wheel-right))) + (with-suppressed-warnings + ((obsolete + mouse-wheel-down-event mouse-wheel-right-event + mouse-wheel-up-event mouse-wheel-left-event)) + `( ,mouse-wheel-down-event ,mouse-wheel-up-event + ,mouse-wheel-right-event ,mouse-wheel-left-event + wheel-down wheel-up wheel-left wheel-right)))) nil) (noerror nil) (t diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index e47e2662afa..120972d6cd8 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -678,12 +678,10 @@ characters with appropriate settings of `print-level' and (defun backtrace--print-to-string (sexp &optional limit) ;; This is for use by callers who wrap the call with ;; backtrace--with-output-variables. - (setq limit (or limit backtrace-line-length)) - (with-temp-buffer - (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit)) - ;; Add a unique backtrace-form property. - (put-text-property (point-min) (point) 'backtrace-form (gensym)) - (buffer-string))) + (propertize (cl-print-to-string-with-limit #'backtrace--print sexp + (or limit backtrace-line-length)) + ;; Add a unique backtrace-form property. + 'backtrace-form (gensym))) (defun backtrace-print-frame (frame view) "Insert a backtrace FRAME at point formatted according to VIEW. @@ -722,9 +720,10 @@ Format it according to VIEW." (def (find-function-advised-original fun)) (fun-file (or (symbol-file fun 'defun) (and (subrp def) - (not (eq 'unevalled (cdr (subr-arity def)))) + (not (special-form-p def)) (find-lisp-object-file-name fun def)))) - (fun-pt (point))) + (fun-beg (point)) + (fun-end nil)) (cond ((and evald (not debugger-stack-frame-as-list)) (if (atom fun) @@ -734,6 +733,7 @@ Format it according to VIEW." fun (when (and args (backtrace--line-length-or-nil)) (/ backtrace-line-length 2))))) + (setq fun-end (point)) (if args (insert (backtrace--print-to-string args @@ -749,10 +749,16 @@ Format it according to VIEW." (t (let ((fun-and-args (cons fun args))) (insert (backtrace--print-to-string fun-and-args))) - (cl-incf fun-pt))) + ;; Skip the open-paren. + (cl-incf fun-beg))) (when fun-file - (make-text-button fun-pt (+ fun-pt - (length (backtrace--print-to-string fun))) + (make-text-button fun-beg + (or fun-end + (+ fun-beg + ;; FIXME: `backtrace--print-to-string' will + ;; not necessarily print FUN in the same way + ;; as it did when it was in FUN-AND-ARGS! + (length (backtrace--print-to-string fun)))) :type 'help-function-def 'help-args (list fun fun-file))) ;; After any frame that uses eval-buffer, insert a comment that diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ea163723a3e..4095726d276 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -164,7 +164,7 @@ Earlier variables shadow later ones with the same name.") ;; The byte-code will be really inlined in byte-compile-unfold-bcf. (byte-compile--check-arity-bytecode form fn) `(,fn ,@(cdr form))) - ((or `(lambda . ,_) `(closure . ,_)) + ((pred interpreted-function-p) ;; While byte-compile-unfold-bcf can inline dynbind byte-code into ;; letbind byte-code (or any other combination for that matter), we ;; can only inline dynbind source into dynbind source or lexbind @@ -1512,13 +1512,15 @@ See Info node `(elisp) Integer Basics'." (put 'nthcdr 'byte-optimizer #'byte-optimize-nthcdr) (defun byte-optimize-nthcdr (form) (if (= (safe-length form) 3) - (if (memq (nth 1 form) '(0 1 2)) - (let ((count (nth 1 form))) - (setq form (nth 2 form)) - (while (>= (setq count (1- count)) 0) - (setq form (list 'cdr form))) - form) - form) + (let ((count (nth 1 form))) + (cond ((and (integerp count) (<= count 3)) + (setq form (nth 2 form)) + (while (>= (setq count (1- count)) 0) + (setq form (list 'cdr form))) + form) + ((not (eq (car form) 'nthcdr)) + (cons 'nthcdr (cdr form))) ; use the nthcdr byte-op + (t form))) form)) (put 'cons 'byte-optimizer #'byte-optimize-cons) @@ -1870,6 +1872,7 @@ See Info node `(elisp) Integer Basics'." charsetp ;; data.c arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p + interpreted-function-p closurep byteorder car-safe cdr-safe char-or-string-p char-table-p condition-variable-p consp eq floatp indirect-function integer-or-marker-p integerp keywordp listp markerp diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index cc176821026..f9e86d88806 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -217,6 +217,11 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (cadr elem))) val))))) +(defalias 'byte-run--set-function-type + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''function-type (list 'quote val)))) + ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list @@ -239,7 +244,8 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (list 'speed #'byte-run--set-speed) (list 'completion #'byte-run--set-completion) (list 'modes #'byte-run--set-modes) - (list 'interactive-args #'byte-run--set-interactive-args)) + (list 'interactive-args #'byte-run--set-interactive-args) + (list 'type #'byte-run--set-function-type)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2b5eb34e571..d9890b5c37a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1596,24 +1596,39 @@ extra args." (when (and (symbolp (car form)) (stringp (nth 1 form)) (get (car form) 'byte-compile-format-like)) - (let ((nfields (with-temp-buffer - (insert (nth 1 form)) - (goto-char (point-min)) - (let ((i 0) (n 0)) - (while (re-search-forward "%." nil t) - (backward-char) - (unless (eq ?% (char-after)) - (setq i (if (looking-at "\\([0-9]+\\)\\$") - (string-to-number (match-string 1) 10) - (1+ i)) - n (max n i))) - (forward-char)) - n))) - (nargs (- (length form) 2))) + (let* ((nargs (length (cddr form))) + (nfields 0) + (format-str (nth 1 form)) + (len (length format-str)) + (start 0)) + (while (and (< start len) + (string-match + (rx "%" + (? (group (+ digit)) "$") ; field + (* (in "+ #0-")) ; flags + (* digit) ; width + (? "." (* digit)) ; precision + (? (group (in "sdioxXefgcS%")))) ; spec + format-str start)) + (let ((field (if (match-beginning 1) + (string-to-number (match-string 1 format-str)) + (1+ nfields))) + (spec (and (match-beginning 2) + (aref format-str (match-beginning 2))))) + (setq start (match-end 0)) + (cond + ((not spec) + (byte-compile-warn-x + form "Bad format sequence in call to `%s' at string offset %d" + (car form) (match-beginning 0))) + ((not (eq spec ?%)) + (setq nfields (max field nfields)))))) (unless (= nargs nfields) - (byte-compile-warn-x (car form) - "`%s' called with %d args to fill %d format field(s)" (car form) - nargs nfields))))) + (byte-compile-warn-x + (car form) "`%s' called with %d argument%s to fill %d format field%s" + (car form) + nargs (if (= nargs 1) "" "s") + nfields (if (= nfields 1) "" "s")))))) (dolist (elt '(format message format-message error)) (put elt 'byte-compile-format-like t)) @@ -2149,6 +2164,8 @@ If compilation is needed, this functions returns the result of (cons tempfile target-file)) (rename-file tempfile target-file t))))) +(defvar bytecomp--inhibit-lexical-cookie-warning nil) + ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -2234,7 +2251,8 @@ See also `emacs-lisp-byte-compile-and-load'." (setq buffer-read-only nil filename buffer-file-name)) ;; Don't inherit lexical-binding from caller (bug#12938). - (unless (local-variable-p 'lexical-binding) + (unless (or (local-variable-p 'lexical-binding) + bytecomp--inhibit-lexical-cookie-warning) (let ((byte-compile-current-buffer (current-buffer))) (displaying-byte-compile-warnings (byte-compile-warn-x @@ -2823,7 +2841,7 @@ not to take responsibility for the actual compilation of the code." ;; Tell the caller that we didn't compile it yet. nil) - (let* ((code (byte-compile-lambda (cons arglist body) t))) + (let ((code (byte-compile-lambda `(lambda ,arglist . ,body)))) (if this-one ;; A definition in b-c-initial-m-e should always take precedence ;; during compilation, so don't let it be redefined. (Bug#8647) @@ -2897,9 +2915,14 @@ otherwise, print without quoting." (defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. FUN should be an interpreted closure." - (pcase-let* ((`(closure ,env ,args . ,body) fun) - (`(,preamble . ,body) (macroexp-parse-body body)) - (renv ())) + (let* ((args (aref fun 0)) + (body (aref fun 1)) + (env (aref fun 2)) + (docstring (function-documentation fun)) + (iform (interactive-form fun)) + (preamble `(,@(if docstring (list docstring)) + ,@(if iform (list iform)))) + (renv ())) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) (cond @@ -2936,10 +2959,12 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (or (symbolp form) (eq (car-safe fun) 'closure)) + (when (or (symbolp form) (interpreted-function-p fun)) ;; `fun' is a function *value*, so try to recover its ;; corresponding source code. - (when (setq lexical-binding (eq (car-safe fun) 'closure)) + (if (not (interpreted-function-p fun)) + (setq lexical-binding nil) + (setq lexical-binding (not (null (aref fun 2)))) (setq fun (byte-compile--reify-function fun))) (setq need-a-value t)) ;; Expand macros. @@ -3044,14 +3069,12 @@ If FORM is a lambda or a macro, byte-compile it as a function." byte-compile--known-dynamic-vars) ", ")))) -(defun byte-compile-lambda (fun &optional add-lambda reserved-csts) +(defun byte-compile-lambda (fun &optional reserved-csts) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original lambda-expression." - (if add-lambda - (setq fun (cons 'lambda fun)) - (unless (eq 'lambda (car-safe fun)) - (error "Not a lambda list: %S" fun))) + (unless (eq 'lambda (car-safe fun)) + (error "Not a lambda list: %S" fun)) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun. @@ -3402,8 +3425,8 @@ lambda-expression." (t ".")))) (let ((mutargs (function-get (car form) 'mutates-arguments))) (when mutargs - (dolist (idx (if (eq mutargs 'all-but-last) - (number-sequence 1 (- (length form) 2)) + (dolist (idx (if (symbolp mutargs) + (funcall mutargs form) mutargs)) (let ((arg (nth idx form))) (when (and (or (and (eq (car-safe arg) 'quote) @@ -3472,13 +3495,15 @@ lambda-expression." (if byte-compile--for-effect (byte-compile-discard))))) +(defun bytecomp--sort-call-in-place-p (form) + (or (= (length form) 3) ; old-style + (plist-get (cddr form) :in-place))) ; new-style + (defun bytecomp--actually-important-return-value-p (form) "Whether FORM is really a call with a return value that should not go unused. This assumes the function has the `important-return-value' property." (cond ((eq (car form) 'sort) - ;; For `sort', we only care about non-destructive uses. - (and (zerop (% (length form) 2)) ; new-style call - (not (plist-get (cddr form) :in-place)))) + (not (bytecomp--sort-call-in-place-p form))) (t t))) (let ((important-return-value-fns @@ -3504,18 +3529,27 @@ This assumes the function has the `important-return-value' property." (dolist (fn important-return-value-fns) (put fn 'important-return-value t))) +(defun bytecomp--mutargs-nconc (form) + ;; For `nconc', all arguments but the last are mutated. + (number-sequence 1 (- (length form) 2))) + +(defun bytecomp--mutargs-sort (form) + ;; For `sort', the first argument is mutated if the call is in-place. + (and (bytecomp--sort-call-in-place-p form) '(1))) + (let ((mutating-fns ;; FIXME: Should there be a function declaration for this? ;; ;; (FUNC . ARGS) means that FUNC mutates arguments whose indices are - ;; in the list ARGS, starting at 1, or all but the last argument if - ;; ARGS is `all-but-last'. + ;; in the list ARGS, starting at 1. ARGS can also be a function + ;; taking the function call form as argument and returning the + ;; list of indices. '( (setcar 1) (setcdr 1) (aset 1) (nreverse 1) - (nconc . all-but-last) + (nconc . bytecomp--mutargs-nconc) (nbutlast 1) (ntake 2) - (sort 1) + (sort . bytecomp--mutargs-sort) (delq 2) (delete 2) (delete-dups 1) (delete-consecutive-dups 1) (plist-put 1) @@ -4122,7 +4156,7 @@ This function is never called when `lexical-binding' is nil." (docstring-exp (nth 3 form)) (body (nthcdr 4 form)) (fun - (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) + (byte-compile-lambda `(lambda ,vars . ,body) (length env)))) (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) @@ -4157,16 +4191,13 @@ This function is never called when `lexical-binding' is nil." ;; Nontrivial doc string expression: create a bytecode object ;; from small pieces at run time. `(make-byte-code - ',(aref fun 0) ; 15-bit form of arglist descriptor. - ',(aref fun 1) ; The byte-code. - (vconcat (vector . ,env) ',(aref fun 2)) ; constant vector. - ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) - (if docstring-exp - `(,(car rest) - ,(byte-run-strip-symbol-positions docstring-exp) - ,@(cddr rest)) - rest)))) - )))) + ,(aref fun 0) ; 15-bit form of arglist descriptor. + ,(aref fun 1) ; The byte-code. + (vconcat (vector . ,env) ,(aref fun 2)) ; constant vector + ,(aref fun 3) ; max stack depth + ,(byte-run-strip-symbol-positions docstring-exp) + ;; optional interactive spec and anything else, all quoted + ,@(mapcar (lambda (x) `',x) (drop 5 (append fun nil))))))))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." @@ -5119,7 +5150,6 @@ binding slots have been popped." ;; `arglist' is the list of arguments (or t if not recognized). ;; `body' is the body of `lam' (or t if not recognized). ((or `(lambda ,arglist . ,body) - ;; `(closure ,_ ,arglist . ,body) (and `(internal-make-closure ,arglist . ,_) (let body t)) (and (let arglist t) (let body t))) lam)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 4ff47971351..e6a78f07762 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -902,7 +902,7 @@ lexically and dynamically bound symbols actually used by FORM." (delete-dups cconv--dynbindings))))) (cons fvs dyns))))) -(defun cconv-make-interpreted-closure (fun env) +(defun cconv-make-interpreted-closure (args body env docstring iform) "Make a closure for the interpreter. This is intended to be called at runtime by the ELisp interpreter (when the code has not been compiled). @@ -911,22 +911,27 @@ ENV is the runtime representation of the lexical environment, i.e. a list whose elements can be either plain symbols (which indicate that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE) for the lexical bindings." - (cl-assert (eq (car-safe fun) 'lambda)) + (cl-assert (consp body)) + (cl-assert (listp args)) (let ((lexvars (delq nil (mapcar #'car-safe env)))) - (if (or (null lexvars) - ;; Functions with a `:closure-dont-trim-context' marker - ;; should keep their whole context untrimmed (bug#59213). - (and (eq :closure-dont-trim-context (nth 2 fun)) - ;; Check the function doesn't just return the magic keyword. - (nthcdr 3 fun))) + (if (or + ;; Functions with a `:closure-dont-trim-context' marker + ;; should keep their whole context untrimmed (bug#59213). + (and (eq :closure-dont-trim-context (car body)) + ;; Check the function doesn't just return the magic keyword. + (cdr body) + ;; Drop the magic marker from the closure. + (setq body (cdr body))) + ;; There's no var to capture, so skip the analysis. + (null lexvars)) ;; The lexical environment is empty, or needs to be preserved, ;; so there's no need to look for free variables. - ;; Attempting to replace ,(cdr fun) by a macroexpanded version - ;; causes bootstrap to fail. - `(closure ,env . ,(cdr fun)) + ;; Attempting to replace body by a macroexpanded version + ;; caused bootstrap to fail. + (make-interpreted-closure args body env docstring iform) ;; We could try and cache the result of the macroexpansion and ;; `cconv-fv' analysis. Not sure it's worth the trouble. - (let* ((form `#',fun) + (let* ((form `#'(lambda ,args ,iform . ,body)) (expanded-form (let ((lexical-binding t) ;; Tell macros which dialect is in use. ;; Make the macro aware of any defvar declarations in scope. @@ -935,10 +940,10 @@ for the lexical bindings." (append env macroexp--dynvars) env))) (macroexpand-all form macroexpand-all-environment))) ;; Since we macroexpanded the body, we may as well use that. - (expanded-fun-cdr + (expanded-fun-body (pcase expanded-form - (`#'(lambda . ,cdr) cdr) - (_ (cdr fun)))) + (`#'(lambda ,_args ,_iform . ,newbody) newbody) + (_ body))) (dynvars (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env))) (fvs (cconv-fv expanded-form lexvars dynvars)) @@ -946,7 +951,8 @@ for the lexical bindings." (cdr fvs)))) ;; Never return a nil env, since nil means to use the dynbind ;; dialect of ELisp. - `(closure ,(or newenv '(t)) . ,expanded-fun-cdr))))) + (make-interpreted-closure args expanded-fun-body (or newenv '(t)) + docstring iform))))) (provide 'cconv) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 437dea2d6a9..19429ce80df 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -807,13 +807,19 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (insert (substitute-command-keys (if ch "', " "'")))) (insert ".\n"))) + ;; Describe all the slots in this class. + ;; Put it before the docstring, since the docstring may want + ;; to refer to the slots. + (cl--describe-class-slots class) + ;; Type's documentation. (let ((doc (cl--class-docstring class))) (when doc - (insert "\n" doc "\n\n"))) - - ;; Describe all the slots in this class. - (cl--describe-class-slots class) + (insert (if (save-excursion + (or (< (skip-chars-backward "\n") -1) (bobp))) + "" + "\n") + doc "\n\n"))) ;; Describe all the methods specific to this class. (let ((generics (cl-generic-all-functions type))) @@ -910,7 +916,14 @@ Outputs to the current buffer." (mapcar (lambda (slot) (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) - (cl-prin1-to-string (cl--slot-descriptor-type slot)) + (let ((type (cl--slot-descriptor-type slot))) + (cond + ((eq type t) "") + ((and type (symbolp type) (cl--find-class type)) + (make-text-button (symbol-name type) nil + 'type 'help-type + 'help-args (list type))) + (t (cl-prin1-to-string type)))) (cl-prin1-to-string (cl--slot-descriptor-initform slot)) (let ((doc (alist-get :documentation (cl--slot-descriptor-props slot)))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index a84ef4a34b2..2e501005bf7 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3010,6 +3010,7 @@ To see the documentation for a defined struct type, use ;; All the above is for the following def-form. &rest &or symbolp (symbolp &optional def-form &rest sexp)))) (let* ((name (if (consp struct) (car struct) struct)) + (warning nil) (opts (cdr-safe struct)) (slots nil) (defaults nil) @@ -3094,7 +3095,10 @@ To see the documentation for a defined struct type, use (setq descs (nconc (make-list (car args) '(cl-skip-slot)) descs))) (t - (error "Structure option %s unrecognized" opt))))) + (setq warning + (macroexp-warn-and-return + (format "Structure option %S unrecognized" opt) + warning nil nil (list opt struct))))))) (unless (or include-name type ;; Don't create a bogus parent to `cl-structure-object' ;; while compiling the (cl-defstruct cl-structure-object ..) @@ -3333,6 +3337,7 @@ To see the documentation for a defined struct type, use (cl-struct-define ',name ,docstring ',include-name ',(or type 'record) ,(eq named t) ',descs ',tag-symbol ',tag ',print-auto)) + ,warning ',name))) ;;; Add cl-struct support to pcase @@ -3479,6 +3484,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;;;###autoload (define-inline cl-typep (val type) + "Return t if VAL is of type TYPE, nil otherwise." (inline-letevals (val) (pcase (inline-const-val type) ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index d23ad3972a9..fa745396b02 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -224,8 +224,8 @@ (index-table nil :type hash-table) (tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object. (type nil :type (memq (vector list))) - (named nil :type bool) - (print nil :type bool) + (named nil :type boolean) + (print nil :type boolean) (children-sym nil :type symbol) ;This sym's value holds the tags of children. ) @@ -444,13 +444,24 @@ For this build of Emacs it's %dbit." ) (cl--define-built-in-type compiled-function (function) "Abstract type of functions that have been compiled.") -(cl--define-built-in-type byte-code-function (compiled-function) +(cl--define-built-in-type closure (function) + "Abstract type of functions represented by a vector-like object. +You can access the object's internals with `aref'. +The fields are used as follows: + + 0 [args] Argument list (either a list or an integer) + 1 [code] Either a byte-code string or a list of Lisp forms + 2 [constants] Either vector of constants or a lexical environment + 3 [stackdepth] Maximum amount of stack depth used by the byte-code + 4 [docstring] The documentation, or a reference to it + 5 [iform] The interactive form (if present)") +(cl--define-built-in-type byte-code-function (compiled-function closure) "Type of functions that have been byte-compiled.") (cl--define-built-in-type subr (atom) "Abstract type of functions compiled to machine code.") (cl--define-built-in-type module-function (function) "Type of functions provided via the module API.") -(cl--define-built-in-type interpreted-function (function) +(cl--define-built-in-type interpreted-function (closure) "Type of functions that have not been compiled.") (cl--define-built-in-type special-form (subr) "Type of the core syntactic elements of the Emacs Lisp language.") diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 5e5eee1da9e..e8e6502e66f 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -180,7 +180,7 @@ into a button whose action shows the function's disassembly.") ;; FIXME: Don't degenerate to `prin1' for the contents of char-tables ;; and records! -(cl-defmethod cl-print-object ((object compiled-function) stream) +(cl-defmethod cl-print-object ((object byte-code-function) stream) (unless stream (setq stream standard-output)) ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results. (princ "#f(compiled-function " stream) @@ -237,6 +237,38 @@ into a button whose action shows the function's disassembly.") 'byte-code-function object))))) (princ ")" stream))) +(cl-defmethod cl-print-object ((object interpreted-function) stream) + (unless stream (setq stream standard-output)) + (princ "#f(lambda " stream) + (let ((args (help-function-arglist object 'preserve-names))) + ;; It's tempting to print the arglist from the "usage" info in the + ;; doc (e.g. for `&key` args), but that only makes sense if we + ;; *don't* print the body, since otherwise the body will tend to + ;; refer to args that don't appear in the arglist. + (if args + (prin1 args stream) + (princ "()" stream))) + (let ((env (aref object 2))) + (if (null env) + (princ " :dynbind" stream) + (princ " " stream) + (cl-print-object + (vconcat (mapcar (lambda (x) (if (consp x) (list (car x) (cdr x)) x)) + env)) + stream))) + (let* ((doc (documentation object 'raw))) + (when doc + (princ " " stream) + (prin1 doc stream))) + (let ((inter (interactive-form object))) + (when inter + (princ " " stream) + (cl-print-object inter stream))) + (dolist (exp (aref object 1)) + (princ " " stream) + (cl-print-object exp stream)) + (princ ")" stream)) + ;; This belongs in oclosure.el, of course, but some load-ordering issues make it ;; complicated. (cl-defmethod cl-print-object ((object accessor) stream) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index e46955fd968..42f54603899 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -452,14 +452,15 @@ to avoid corrupting the original SEQ. (apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun cl-nsubstitute (cl-new cl-old cl-seq &rest cl-keys) +(defun cl-nsubstitute (cl-new cl-old seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () - (let ((len (length cl-seq))) + (let* ((cl-seq (if (stringp seq) (string-to-vector seq) seq)) + (len (length cl-seq))) (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count len)) 0) (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count (/ len 2)))) (let ((cl-p (nthcdr cl-start cl-seq))) @@ -483,8 +484,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (progn (aset cl-seq cl-start cl-new) (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start))))))) - cl-seq)) + (setq cl-start (1+ cl-start)))))) + (if (stringp seq) (concat cl-seq) cl-seq)))) ;;;###autoload (defun cl-nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 4edfe811586..355988838c7 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -68,7 +68,7 @@ Used to modify the compiler environment." :risky t :version "28.1") -(defconst comp-known-type-specifiers +(defconst comp-primitive-type-specifiers `( ;; Functions we can trust not to be redefined, or, if redefined, ;; to expose the same type. The vast majority of these are @@ -97,7 +97,6 @@ Used to modify the compiler environment." (assq (function (t list) list)) (atan (function (number &optional number) float)) (atom (function (t) boolean)) - (bignump (function (t) boolean)) (bobp (function () boolean)) (bolp (function () boolean)) (bool-vector-count-consecutive @@ -107,7 +106,6 @@ Used to modify the compiler environment." (bool-vector-p (function (t) boolean)) (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) (boundp (function (symbol) boolean)) - (buffer-end (function ((or number marker)) integer)) (buffer-file-name (function (&optional buffer) (or string null))) (buffer-list (function (&optional frame) list)) (buffer-local-variables (function (&optional buffer) list)) @@ -118,7 +116,9 @@ Used to modify the compiler environment." (buffer-substring (function ((or integer marker) (or integer marker)) string)) (bufferp (function (t) boolean)) + (closurep (function (t) boolean)) (byte-code-function-p (function (t) boolean)) + (interpreted-function-p (function (t) boolean)) (capitalize (function ((or integer string)) (or integer string))) (car (function (list) t)) (car-less-than-car (function (list list) boolean)) @@ -155,8 +155,6 @@ Used to modify the compiler environment." (copy-sequence (function (sequence) sequence)) (copysign (function (float float) float)) (cos (function (number) float)) - (count-lines - (function ((or integer marker) (or integer marker) &optional t) integer)) (current-buffer (function () buffer)) (current-global-map (function () cons)) (current-indentation (function () integer)) @@ -169,7 +167,6 @@ Used to modify the compiler environment." (current-time-zone (function (&optional (or number list) (or symbol string cons integer)) cons)) - (custom-variable-p (function (symbol) t)) (decode-char (function (cons t) (or fixnum null))) (decode-time (function (&optional (or number list) (or symbol string cons integer) @@ -177,7 +174,6 @@ Used to modify the compiler environment." cons)) (default-boundp (function (symbol) boolean)) (default-value (function (symbol) t)) - (degrees-to-radians (function (number) float)) (documentation (function ((or function symbol subr) &optional t) (or null string))) (downcase (function ((or fixnum string)) (or fixnum string))) @@ -190,7 +186,6 @@ Used to modify the compiler environment." (eql (function (t t) boolean)) (equal (function (t t) boolean)) (error-message-string (function (list) string)) - (eventp (function (t) boolean)) (exp (function (number) float)) (expt (function (number number) number)) (fboundp (function (symbol) boolean)) @@ -205,7 +200,6 @@ Used to modify the compiler environment." (file-readable-p (function (string) boolean)) (file-symlink-p (function (string) (or boolean string))) (file-writable-p (function (string) boolean)) - (fixnump (function (t) boolean)) (float (function (number) float)) (float-time (function (&optional (or number list)) float)) (floatp (function (t) boolean)) @@ -228,18 +222,12 @@ Used to modify the compiler environment." (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) (get-file-buffer (function (string) (or null buffer))) - (get-largest-window (function (&optional t t t) (or window null))) - (get-lru-window (function (&optional t t t) (or window null))) - (getenv (function (string &optional frame) (or null string))) (gethash (function (t hash-table &optional t) t)) (hash-table-count (function (hash-table) integer)) (hash-table-p (function (t) boolean)) (identity (function (t) t)) - (ignore (function (&rest t) null)) - (int-to-string (function (number) string)) (integer-or-marker-p (function (t) boolean)) (integerp (function (t) boolean)) - (interactive-p (function () boolean)) (intern-soft (function ((or string symbol) &optional (or obarray vector)) symbol)) (invocation-directory (function () string)) @@ -248,8 +236,6 @@ Used to modify the compiler environment." (keymap-parent (function (cons) (or cons null))) (keymapp (function (t) boolean)) (keywordp (function (t) boolean)) - (last (function (list &optional integer) list)) - (lax-plist-get (function (list t) t)) (ldexp (function (number integer) float)) (length (function (t) (integer 0 *))) (length< (function (sequence fixnum) boolean)) @@ -263,7 +249,6 @@ Used to modify the compiler environment." (local-variable-p (function (symbol &optional buffer) boolean)) (locale-info (function ((member codeset days months paper)) (or null string))) (log (function (number number) float)) - (log10 (function (number) float)) (logand (function (&rest (or integer marker)) integer)) (logb (function (number) integer)) (logcount (function (integer) integer)) @@ -271,7 +256,6 @@ Used to modify the compiler environment." (lognot (function (integer) integer)) (logxor (function (&rest (or integer marker)) integer)) ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? - (lsh (function (integer integer) integer)) (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) @@ -280,14 +264,12 @@ Used to modify the compiler environment." (make-marker (function () marker)) (make-string (function (integer fixnum &optional t) string)) (make-symbol (function (string) symbol)) - (mark (function (&optional t) (or integer null))) (mark-marker (function () marker)) (marker-buffer (function (marker) (or buffer null))) (markerp (function (t) boolean)) (max (function ((or number marker) &rest (or number marker)) number)) (max-char (function (&optional t) fixnum)) (member (function (t list) list)) - (memory-limit (function () integer)) (memq (function (t list) list)) (memql (function (t list) list)) (min (function ((or number marker) &rest (or number marker)) number)) @@ -296,7 +278,6 @@ Used to modify the compiler environment." (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) - (mouse-movement-p (function (t) boolean)) (multibyte-char-to-unibyte (function (fixnum) fixnum)) (natnump (function (t) boolean)) (next-window (function (&optional window t t) window)) @@ -308,9 +289,7 @@ Used to modify the compiler environment." (number-or-marker-p (function (t) boolean)) (number-to-string (function (number) string)) (numberp (function (t) boolean)) - (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) - (parse-colon-path (function (string) list)) (plist-get (function (list t &optional t) t)) (plist-member (function (list t &optional t) list)) (point (function () integer)) @@ -323,13 +302,11 @@ Used to modify the compiler environment." (processp (function (t) boolean)) (proper-list-p (function (t) (or fixnum null))) (propertize (function (string &rest t) string)) - (radians-to-degrees (function (number) float)) (rassoc (function (t list) list)) (rassq (function (t list) list)) (read-from-string (function (string &optional integer integer) cons)) (recent-keys (function (&optional (or cons null)) vector)) (recursion-depth (function () integer)) - (regexp-opt (function (list) string)) (regexp-quote (function (string) string)) (region-beginning (function () integer)) (region-end (function () integer)) @@ -385,7 +362,6 @@ Used to modify the compiler environment." (upcase (function ((or fixnum string)) (or fixnum string))) (user-full-name (function (&optional integer) (or string null))) (user-login-name (function (&optional integer) (or string null))) - (user-original-login-name (function (&optional integer) (or string null))) (user-real-login-name (function () string)) (user-real-uid (function () integer)) (user-uid (function () integer)) @@ -398,13 +374,8 @@ Used to modify the compiler environment." (window-live-p (function (t) boolean)) (window-valid-p (function (t) boolean)) (windowp (function (t) boolean)) - (zerop (function (number) boolean)) - ;; Type hints - (comp-hint-fixnum (function (t) fixnum)) - (comp-hint-cons (function (t) cons)) ;; Non returning functions (throw (function (t t) nil)) - (error (function (string &rest t) nil)) (signal (function (symbol t) nil))) "Alist used for type propagation.") @@ -530,22 +501,27 @@ Account for `native-comp-eln-load-path' and `comp-native-version-dir'." (defun comp-function-type-spec (function) "Return the type specifier of FUNCTION. -This function returns a cons cell whose car is the function -specifier, and cdr is a symbol, either `inferred' or `know'. -If the symbol is `inferred', the type specifier is automatically -inferred from the code itself by the native compiler; if it is -`know', the type specifier comes from `comp-known-type-specifiers'." - (let ((kind 'know) - type-spec ) - (when-let ((res (assoc function comp-known-type-specifiers))) +This function returns a cons cell whose car is the function specifier, +and cdr is a symbol, either `inferred' or `declared'. If the symbol is +`inferred', the type specifier is automatically inferred from the code +itself by the native compiler; if it is `declared', the type specifier +comes from `comp-primitive-type-specifiers' or the function type declaration +itself." + (let ((kind 'declared) + type-spec) + (when-let ((res (assoc function comp-primitive-type-specifiers))) + ;; Declared primitive (setf type-spec (cadr res))) (let ((f (and (symbolp function) (symbol-function function)))) - (when (and f - (null type-spec) - (subr-native-elisp-p f)) - (setf kind 'inferred - type-spec (subr-type f)))) + (when (and f (null type-spec)) + (if-let ((delc-type (function-get function 'function-type))) + ;; Declared Lisp function + (setf type-spec delc-type) + (when (subr-native-elisp-p f) + ;; Native compiled inferred + (setf kind 'inferred + type-spec (subr-type f)))))) (when type-spec (cons type-spec kind)))) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index cbfb9540f03..b13c63a2a08 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -89,7 +89,10 @@ Integer values are handled in the `range' slot.") "Return all non built-in type names currently defined." (let (res) (mapatoms (lambda (x) - (when (cl-find-class x) + (when-let ((class (cl-find-class x)) + ;; Ignore EIEIO classes as they can be + ;; redefined at runtime. + (gate (not (eq 'eieio--class (type-of class))))) (push x res))) obarray) res)) @@ -909,7 +912,9 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (defun comp-cstr-fixnum-p (cstr) "Return t if CSTR is certainly a fixnum." (with-comp-cstr-accessors - (when (null (neg cstr)) + (when (and (null (neg cstr)) + (null (valset cstr)) + (null (typeset cstr))) (when-let (range (range cstr)) (let* ((low (caar range)) (high (cdar (last range)))) @@ -924,11 +929,9 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (with-comp-cstr-accessors (and (null (range cstr)) (null (neg cstr)) - (or (and (null (valset cstr)) + (and (or (null (typeset cstr)) (equal (typeset cstr) '(symbol))) - (and (or (null (typeset cstr)) - (equal (typeset cstr) '(symbol))) - (cl-every #'symbolp (valset cstr))))))) + (cl-every #'symbolp (valset cstr)))))) (defsubst comp-cstr-cons-p (cstr) "Return t if CSTR is certainly a cons." @@ -938,6 +941,28 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +(defun comp-cstr-type-p (cstr type) + "Return t if CSTR is certainly of type TYPE." + (when + (with-comp-cstr-accessors + (cl-case type + (integer + (if (or (valset cstr) (neg cstr)) + nil + (or (equal (typeset cstr) '(integer)) + (and (range cstr) + (or (null (typeset cstr)) + (equal (typeset cstr) '(integer))))))) + (t + (if-let ((pred (get type 'cl-deftype-satisfies))) + (and (null (range cstr)) + (null (neg cstr)) + (and (or (null (typeset cstr)) + (equal (typeset cstr) `(,type))) + (cl-every pred (valset cstr)))) + (error "Unknown predicate for type %s" type))))) + t)) + ;; Move to comp.el? (defsubst comp-cstr-cl-tag-p (cstr) "Return non-nil if CSTR is a CL tag." diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ec55ed98ee..fa866b802cc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -179,16 +179,31 @@ For internal use by the test suite only.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -(defconst comp-known-func-cstr-h +(defconst comp-primitive-func-cstr-h (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) with h = (make-hash-table :test #'eq) - for (f type-spec) in comp-known-type-specifiers + for (f type-spec) in comp-primitive-type-specifiers for cstr = (comp-type-spec-to-cstr type-spec) do (puthash f cstr h) finally return h) "Hash table function -> `comp-constraint'.") +(defsubst comp--symbol-func-to-fun (symbol-func) + "Given a function called SYMBOL-FUNC return its `comp-func'." + (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt))) + +(defun comp--get-function-cstr (function) + "Given FUNCTION return the corresponding `comp-constraint'." + (when (symbolp function) + (let ((f (symbol-function function))) + (or (gethash f comp-primitive-func-cstr-h) + (when-let ((type (or (when-let ((f (comp--symbol-func-to-fun function))) + (comp-func-declared-type f)) + (function-get function 'function-type)))) + (comp-type-spec-to-cstr type)))))) + ;; Keep it in sync with the `cl-deftype-satisfies' property set in ;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the ;; relation type <-> predicate is not bijective (bug#45576). @@ -515,6 +530,8 @@ CFG is mutated by a pass.") :documentation "Optimization level (see `native-comp-speed').") (pure nil :type boolean :documentation "t if pure nil otherwise.") + (declared-type nil :type list + :documentation "Declared function type.") (type nil :type (or null comp-mvar) :documentation "Mvar holding the derived return type.")) @@ -591,11 +608,6 @@ In use by the back-end." finally return t) t)) -(defsubst comp--symbol-func-to-fun (symbol-func) - "Given a function called SYMBOL-FUNC return its `comp-func'." - (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt))) - (defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) @@ -813,6 +825,7 @@ clashes." (comp-func-lap func) lap (comp-func-frame-size func) (comp--byte-frame-size byte-func) (comp-func-speed func) (comp--spill-speed name) + (comp-func-declared-type func) (comp--spill-decl-spec name 'function-type) (comp-func-pure func) (comp--spill-decl-spec name 'pure)) ;; Store the c-name to have it retrievable from @@ -2102,10 +2115,10 @@ TARGET-BB-SYM is the symbol name of the target block." (when-let ((match (pcase insn (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) - (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (when-let ((cstr-f (comp--get-function-cstr f))) (cl-values f cstr-f lhs args))) (`(,(pred comp--call-op-p) ,f . ,args) - (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (when-let ((cstr-f (comp--get-function-cstr f))) (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop @@ -2642,7 +2655,7 @@ Fold the call in case." (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) args (cdr args))) - (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (when-let ((cstr-f (comp--get-function-cstr f))) (let ((cstr (comp-cstr-f-ret cstr-f))) (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. @@ -3301,11 +3314,13 @@ Prepare every function for final compilation and drive the C back-end." ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) - (declare (gv-setter (lambda (val) `(setf ,x ,val)))) + (declare (type (function (t) fixnum)) + (gv-setter (lambda (val) `(setf ,x ,val)))) x) (defun comp-hint-cons (x) - (declare (gv-setter (lambda (val) `(setf ,x ,val)))) + (declare (type (function (t) cons)) + (gv-setter (lambda (val) `(setf ,x ,val)))) x) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 850cc2085f7..91427166137 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -64,8 +64,11 @@ redefine OBJECT if it is a symbol." obarray 'fboundp t nil nil def)) nil 0 t))) (let ((lb lexical-binding)) - (if (and (consp object) (not (functionp object))) - (setq object `(lambda () ,object))) + (when (and (consp object) (not (eq (car object) 'lambda))) + (setq object + (if (eq (car object) 'byte-code) + (apply #'make-byte-code 0 (cdr object)) + `(lambda () ,object)))) (or indent (setq indent 0)) ;Default indent to zero (save-excursion (if (or interactive-p (null buffer)) @@ -113,23 +116,19 @@ redefine OBJECT if it is a symbol." (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) - (if (eq (car-safe obj) 'byte-code) - (setq obj `(lambda () ,obj))) - (when (consp obj) + (when (or (consp obj) (interpreted-function-p obj)) (unless (functionp obj) (error "Not a function")) - (if (assq 'byte-code obj) - nil - (if interactive-p (message (if name - "Compiling %s's definition..." - "Compiling definition...") - name)) - (setq obj (byte-compile obj)) - (if interactive-p (message "Done compiling. Disassembling...")))) + (if interactive-p (message (if name + "Compiling %s's definition..." + "Compiling definition...") + name)) + (setq obj (byte-compile obj)) + (if interactive-p (message "Done compiling. Disassembling..."))) (cond ((consp obj) (setq args (help-function-arglist obj)) ;save arg list (setq obj (cdr obj)) ;throw lambda away (setq obj (cdr obj))) - ((byte-code-function-p obj) + ((closurep obj) (setq args (help-function-arglist obj))) (t (error "Compilation failed"))) (if (zerop indent) ; not a nested function @@ -171,14 +170,14 @@ redefine OBJECT if it is a symbol." (let ((print-escape-newlines t)) (prin1 interactive (current-buffer)))) (insert "\n")))) - (cond ((and (consp obj) (assq 'byte-code obj)) - (disassemble-1 (assq 'byte-code obj) indent)) - ((byte-code-function-p obj) + (cond ((byte-code-function-p obj) (disassemble-1 obj indent)) (t (insert "Uncompiled body: ") (let ((print-escape-newlines t)) - (prin1 (macroexp-progn obj) + (prin1 (macroexp-progn (if (interpreted-function-p obj) + (aref obj 1) + obj)) (current-buffer)))))) (if interactive-p (message ""))) @@ -265,7 +264,7 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (and (eq (car-safe arg) 'macro) (byte-code-function-p (cdr arg)))) (cond ((byte-code-function-p arg) - (insert "<compiled-function>\n")) + (insert "<byte-code-function>\n")) (t (insert "<compiled macro>\n"))) (disassemble-internal arg @@ -277,6 +276,8 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." arg (+ indent disassemble-recursive-indent))) ((eq (car-safe (car-safe arg)) 'byte-code) + ;; FIXME: I'm 99% sure bytecomp never generates + ;; this any more. (insert "(<byte code>...)\n") (mapc ;Recurse on list of byte-code objects. (lambda (obj) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 4fa05008dd8..ba0f8bad393 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -493,11 +493,8 @@ on if the hook has explicitly disabled it. (extra-keywords nil) (MODE-variable mode) (MODE-buffers (intern (concat global-mode-name "-buffers"))) - (MODE-enable-in-buffers - (intern (concat global-mode-name "-enable-in-buffers"))) - (MODE-check-buffers - (intern (concat global-mode-name "-check-buffers"))) - (MODE-cmhh (intern (concat global-mode-name "-cmhh"))) + (MODE-enable-in-buffer + (intern (concat global-mode-name "-enable-in-buffer"))) (minor-MODE-hook (intern (concat mode-name "-hook"))) (MODE-set-explicitly (intern (concat mode-name "-set-explicitly"))) (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode"))) @@ -557,14 +554,9 @@ Disable the mode if ARG is a negative number.\n\n" ;; Setup hook to handle future mode changes and new buffers. (if ,global-mode - (progn - (add-hook 'after-change-major-mode-hook - #',MODE-enable-in-buffers) - (add-hook 'find-file-hook #',MODE-check-buffers) - (add-hook 'change-major-mode-hook #',MODE-cmhh)) - (remove-hook 'after-change-major-mode-hook #',MODE-enable-in-buffers) - (remove-hook 'find-file-hook #',MODE-check-buffers) - (remove-hook 'change-major-mode-hook #',MODE-cmhh)) + (add-hook 'after-change-major-mode-hook + #',MODE-enable-in-buffer) + (remove-hook 'after-change-major-mode-hook #',MODE-enable-in-buffer)) ;; Go through existing buffers. (dolist (buf (buffer-list)) @@ -588,7 +580,20 @@ modes derived from `text-mode'\". An element with value t means \"use\" and nil means \"don't use\". There's an implicit nil at the end of the list." mode) - :type '(repeat sexp) + :type '(choice + (const :tag "Enable in all major modes" t) + (const :tag "Don't enable in any major mode" nil) + (repeat + :tag "Rules (earlier takes precedence)..." + (choice + (const :tag "Enable in all (other) modes" t) + (const :tag "Don't enable in any (other) mode" nil) + (symbol :value fundamental-mode + :tag "Enable in major mode") + (cons :tag "Don't enable in major modes" + (const :tag "Don't enable in..." not) + (repeat (symbol :value fundamental-mode + :tag "Major mode")))))) ,@group)) ;; Autoloading define-globalized-minor-mode autoloads everything @@ -609,36 +614,19 @@ list." ;; List of buffers left to process. (defvar ,MODE-buffers nil) - ;; The function that calls TURN-ON in each buffer. - (defun ,MODE-enable-in-buffers () - (let ((buffers ,MODE-buffers)) - ;; Clear MODE-buffers to avoid scanning the same list of - ;; buffers in recursive calls to MODE-enable-in-buffers. - ;; Otherwise it could lead to infinite recursion. - (setq ,MODE-buffers nil) - (dolist (buf buffers) - (when (buffer-live-p buf) - (with-current-buffer buf - (unless ,MODE-set-explicitly - (unless (eq ,MODE-major-mode major-mode) - (if ,MODE-variable - (progn - (,mode -1) - (funcall ,turn-on-function)) - (funcall ,turn-on-function)))) - (setq ,MODE-major-mode major-mode)))))) - (put ',MODE-enable-in-buffers 'definition-name ',global-mode) - - (defun ,MODE-check-buffers () - (,MODE-enable-in-buffers) - (remove-hook 'post-command-hook #',MODE-check-buffers)) - (put ',MODE-check-buffers 'definition-name ',global-mode) - - ;; The function that catches kill-all-local-variables. - (defun ,MODE-cmhh () - (add-to-list ',MODE-buffers (current-buffer)) - (add-hook 'post-command-hook #',MODE-check-buffers)) - (put ',MODE-cmhh 'definition-name ',global-mode)))) + ;; The function that calls TURN-ON in the current buffer. + (defun ,MODE-enable-in-buffer () + ;; Remove ourselves from the list of pending buffers. + (setq ,MODE-buffers (delq (current-buffer) ,MODE-buffers)) + (unless ,MODE-set-explicitly + (unless (eq ,MODE-major-mode major-mode) + (if ,MODE-variable + (progn + (,mode -1) + (funcall ,turn-on-function)) + (funcall ,turn-on-function)))) + (setq ,MODE-major-mode major-mode)) + (put ',MODE-enable-in-buffer 'definition-name ',global-mode)))) (defun easy-mmode--globalized-predicate-p (predicate) (cond diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index b27ffbca908..381b7964a35 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1313,6 +1313,12 @@ infinite loops when the code/environment contains a circular object.") (aref sexp 0) (aref sexp 1) (vconcat (mapcar #'edebug-unwrap* (aref sexp 2))) (nthcdr 3 (append sexp ())))) + ((interpreted-function-p sexp) + (make-interpreted-closure + (aref sexp 0) (mapcar #'edebug-unwrap* (aref sexp 1)) + (mapcar (lambda (x) (if (consp x) (cons (car x) (edebug-unwrap* (cdr x))) x)) + (aref sexp 2)) + (documentation sexp 'raw) (interactive-form sexp))) (t sexp))) @@ -4254,7 +4260,7 @@ code location is known." ((pred edebug--symbol-prefixed-p) nil) (_ (when (and skip-next-lambda - (not (memq (car-safe fun) '(closure lambda)))) + (not (interpreted-function-p fun))) (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun)) (unless skip-next-lambda (edebug--unwrap-frame new-frame) diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el index e77c8945dc3..c6fd65e1507 100644 --- a/lisp/emacs-lisp/ert-font-lock.el +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -40,31 +40,34 @@ (require 'pcase) (defconst ert-font-lock--face-symbol-re - (rx (one-or-more (or alphanumeric "-" "_" "."))) - "A face symbol matching regex.") + (rx (+ (or alphanumeric "-" "_" "." "/"))) + "A face symbol matching regex. +The regexp cannot use character classes as these can be redefined by the +major mode of the host language.") (defconst ert-font-lock--face-symbol-list-re (rx "(" (* whitespace) - (one-or-more - (seq (regexp ert-font-lock--face-symbol-re) - (* whitespace))) + (? (regexp ert-font-lock--face-symbol-re)) + (* (+ whitespace) + (regexp ert-font-lock--face-symbol-re)) + (* whitespace) ")") "A face symbol list matching regex.") (defconst ert-font-lock--assertion-line-re (rx ;; leading column assertion (arrow/caret) - (group (or "^" "<-")) - (zero-or-more whitespace) + (group-n 1 (or "^" "<-")) + (* whitespace) ;; possible to have many carets on an assertion line - (group (zero-or-more (seq "^" (zero-or-more whitespace)))) + (group-n 2 (* "^" (* whitespace))) ;; optional negation of the face specification - (group (optional "!")) - (zero-or-more whitespace) + (group-n 3 (optional "!")) + (* whitespace) ;; face symbol name or a list of symbols - (group (or (regexp ert-font-lock--face-symbol-re) - (regexp ert-font-lock--face-symbol-list-re)))) + (group-n 4 (or (regexp ert-font-lock--face-symbol-re) + (regexp ert-font-lock--face-symbol-list-re)))) "An ert-font-lock assertion line regex.") (defun ert-font-lock--validate-major-mode (mode) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 8ab57d2b238..6a665c8181d 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -2816,8 +2816,7 @@ To be used in the ERT results buffer." (insert (format-message " defined in `%s'" (file-name-nondirectory file-name))) (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index f9591661688..847ef53a1cb 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -73,7 +73,7 @@ inferred if not present. `:help-echo': Informational text that explains what happens if the icon is used as a button and you click it." - (declare (indent 2)) + (declare (doc-string 4) (indent 2)) (unless (symbolp name) (error "NAME must be a symbol: %S" name)) (unless (plist-get keywords :version) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 3475d944337..601cc7bf712 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1347,7 +1347,6 @@ Lisp function does not specify a special indentation." (put 'condition-case 'lisp-indent-function 2) (put 'handler-case 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) -(put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index c57b1357f63..9edc11ad132 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -45,6 +45,11 @@ This affects `insert-parentheses' and `insert-pair'." :type 'boolean :group 'lisp) +(defun forward-sexp-default-function (&optional arg) + "Default function for `forward-sexp-function'." + (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) + (if (< arg 0) (backward-prefix-chars))) + (defvar forward-sexp-function nil ;; FIXME: ;; - for some uses, we may want a "sexp-only" version, which only @@ -76,8 +81,7 @@ report errors as appropriate for this kind of usage." (or arg (setq arg 1)) (if forward-sexp-function (funcall forward-sexp-function arg) - (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) - (if (< arg 0) (backward-prefix-chars))))) + (forward-sexp-default-function arg)))) (defun backward-sexp (&optional arg interactive) "Move backward across one balanced expression (sexp). @@ -530,7 +534,8 @@ major mode's decisions about context.") "Return the \"far end\" position of the buffer, in direction ARG. If ARG is positive, that's the end of the buffer. Otherwise, that's the beginning of the buffer." - (declare (side-effect-free error-free)) + (declare (type (function ((or number marker)) integer)) + (side-effect-free error-free)) (if (> arg 0) (point-max) (point-min))) (defun end-of-defun (&optional arg interactive) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index b87b749dd76..bb4797cac8b 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -351,7 +351,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((default-tail nil) (n 0) (rest clauses)) - (while rest + (while (cdr rest) (let ((c (car-safe (car rest)))) (when (cond ((consp c) (and (memq (car c) '(quote function)) (cadr c))) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b603f2e6d0b..7b135c54a15 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -35,6 +35,9 @@ ;;; Code: (declare-function x-popup-dialog "menu.c" (position contents &optional header)) +(declare-function set-text-conversion-style "textconv.c") + +(defvar overriding-text-conversion-style) (defun map-y-or-n-p (prompter actor list &optional help action-alist no-cursor-in-echo-area) @@ -168,7 +171,18 @@ The function's value is the number of actions taken." (key-description (vector help-char))) (if minibuffer-auto-raise (raise-frame (window-frame (minibuffer-window)))) - (setq char (read-event)) + (unwind-protect + ;; We want to inhibit text conversion here, + ;; because it gets in the way when system + ;; input methods are installed. See + ;; https://lists.gnu.org/archive/html/emacs-devel/2024-05/msg00441.html + ;; for the details. + (let ((overriding-text-conversion-style nil)) + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style)) + (setq char (read-event))) + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style))) ;; Show the answer to the question. (message "%s(y, n, !, ., q, %sor %s) %s" prompt user-keys diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5326c520601..36df143a82a 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -185,7 +185,7 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--interactive-form-1 (function) "Like `interactive-form' but preserves the static context if needed." (let ((if (interactive-form function))) - (if (or (null if) (not (eq 'closure (car-safe function)))) + (if (not (and if (interpreted-function-p function))) if (cl-assert (eq 'interactive (car if))) (let ((form (cadr if))) @@ -193,14 +193,14 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") if ;; The interactive is expected to be run in the static context ;; that the function captured. - (let ((ctx (nth 1 function))) + (let ((ctx (aref function 2))) `(interactive ,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form))) ;; If the form jut returns a function, preserve the fact that ;; it just returns a function, which is an info we use in ;; `advice--make-interactive-form'. (if (eq 'lambda (car-safe f)) - `',(eval form ctx) + (eval form ctx) `(eval ',form ',ctx)))))))))) (defun advice--interactive-form (function) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 4da8e61aaa7..165d7c4b6e8 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -146,7 +146,7 @@ (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure "The root parent of all OClosure types" - nil (list (cl--find-class 'function)) + nil (list (cl--find-class 'closure)) '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -431,75 +431,57 @@ ARGS and BODY are the same as for `lambda'." (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 `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))) +This is used as a marker which cconv uses to check that +immutable fields are indeed not mutated." + (cl-assert (closurep oclosure)) + ;; This should happen only for interpreted closures since `cconv.el' + ;; should have optimized away the call to this function. + oclosure) (defun oclosure--copy (oclosure mutlist &rest args) + (cl-assert (closurep oclosure)) (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))))) + (cl-assert (consp (aref oclosure 1))) + (cl-assert (null (aref oclosure 3))) + (cl-assert (symbolp (aref oclosure 4))) + (let ((env (aref oclosure 2))) + (make-interpreted-closure + (aref oclosure 0) + (aref oclosure 1) + (named-let loop ((env env) (args args)) + (if (null args) env + (cons (cons (caar env) (car args)) + (loop (cdr env) (cdr args))))) + (aref oclosure 4) + (if (> (length oclosure) 5) + `(interactive ,(aref oclosure 5))))))) (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))))) + (cl-assert (closurep oclosure)) + (let* ((csts (aref oclosure 2))) + (if (vectorp csts) + (let ((v (aref csts index))) + (if mutable (car v) v)) + (cdr (nth index csts))))) (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))) + (cl-assert (closurep oclosure)) + (let ((csts (aref oclosure 2))) + (if (vectorp csts) + (let ((cell (aref csts index))) + (setcar cell v)) + (setcdr (nth index csts) 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)))))) + "Return the type of OCLOSURE, or nil if the arg is not an OClosure." + (and (closurep oclosure) + (> (length oclosure) 4) + (let ((type (aref oclosure 4))) + (if (symbolp type) type)))) (defconst oclosure--accessor-prototype ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ef056c7909b..c86577b6b26 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -774,6 +774,9 @@ conflicts with its remote repository state." (package-vc-upgrade pkg-desc)))) (message "Done upgrading packages.")) +(declare-function vc-dir-prepare-status-buffer "vc-dir" + (bname dir backend &optional create-new)) + ;;;###autoload (defun package-vc-upgrade (pkg-desc) "Upgrade the package described by PKG-DESC from package's VC repository. @@ -810,7 +813,10 @@ with the remote repository state." (remove-hook 'vc-post-command-functions post-upgrade)))))) (add-hook 'vc-post-command-functions post-upgrade) (with-demoted-errors "Failed to fetch: %S" - (let ((default-directory pkg-dir)) + (require 'vc-dir) + (with-current-buffer (vc-dir-prepare-status-buffer + (format " *package-vc-dir: %s*" pkg-dir) + pkg-dir (vc-responsible-backend pkg-dir)) (vc-pull))))) (defun package-vc--archives-initialize () diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 3428b2375d7..fa0e6bf1a54 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -174,7 +174,13 @@ with \"-q\"). Even if the value is nil, you can type \\[package-initialize] to make installed packages available at any time, or you can -call (package-activate-all) in your init-file." +call (package-activate-all) in your init-file. + +Note that this variable must be set to a non-default value in +your early-init file, as the variable's value is used before +loading the regular init file. Therefore, if you customize it +via Customize, you should save your customized setting into +your `early-init-file'." :type 'boolean :version "24.1") diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index d586fc59939..f89807c37be 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -327,7 +327,8 @@ If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. If a temporary buffer is needed for representation, it will be named after OUT-BUFFER-NAME." - (let* ((old-show-function temp-buffer-show-function) + (let* ((lexical lexical-binding) + (old-show-function temp-buffer-show-function) ;; Use this function to display the buffer. ;; This function either decides not to display it at all ;; or displays it in the usual way. @@ -357,6 +358,7 @@ after OUT-BUFFER-NAME." (pp expression)) (with-current-buffer standard-output (emacs-lisp-mode) + (setq lexical-binding lexical) (setq buffer-read-only nil) (setq-local font-lock-verbose nil))))) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 59c1b7d8e10..f23343a34c6 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -130,7 +130,8 @@ usually more efficient than that of a simplified version: (concat (car parens) (mapconcat \\='regexp-quote strings \"\\\\|\") (cdr parens))))" - (declare (pure t) (side-effect-free t)) + (declare (type (function (list &optional t) string)) + (pure t) (side-effect-free t)) (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 246e41cff0b..7113d5a6241 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -149,6 +149,13 @@ If DEF is a list on the form (FUN MIN-ARGS MAX-ARGS PRED), then If PRED is non-nil, it is a predicate that all actual arguments must satisfy.") +(make-obsolete-variable + 'rx-constituents + "use `rx-let', `rx-let-eval', or `rx-define' instead." + ;; Effectively obsolete since Emacs 27 but only formally declared + ;; obsolete in Emacs 30. + "30.1") + (defvar rx--local-definitions nil "Alist of dynamic local rx definitions. Each entry is: diff --git a/lisp/emacs-lisp/track-changes.el b/lisp/emacs-lisp/track-changes.el new file mode 100644 index 00000000000..2824a70586d --- /dev/null +++ b/lisp/emacs-lisp/track-changes.el @@ -0,0 +1,660 @@ +;;; track-changes.el --- API to react to buffer modifications -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Version: 1.2 +;; Package-Requires: ((emacs "24")) + +;; 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: + +;; This library is a layer of abstraction above `before-change-functions' +;; and `after-change-functions' which takes care of accumulating changes +;; until a time when its client finds it convenient to react to them. +;; +;; It provides an API that is easier to use correctly than our +;; `*-change-functions' hooks. Problems that it claims to solve: +;; +;; - Before and after calls are not necessarily paired. +;; - The beg/end values don't always match. +;; - There's usually only one call to the hooks per command but +;; there can be thousands of calls from within a single command, +;; so naive users will tend to write code that performs poorly +;; in those rare cases. +;; - The hooks are run at a fairly low-level so there are things they +;; really shouldn't do, such as modify the buffer or wait. +;; - The after call doesn't get enough info to rebuild the before-change state, +;; so some callers need to use both before-c-f and after-c-f (and then +;; deal with the first two points above). +;; +;; The new API is almost like `after-change-functions' except that: +;; - It provides the "before string" (i.e. the previous content of +;; the changed area) rather than only its length. +;; - It can combine several changes into larger ones. +;; - Clients do not have to process changes right away, instead they +;; can let changes accumulate (by combining them into a larger change) +;; until it is convenient for them to process them. +;; - By default, changes are signaled at most once per command. + +;; The API consists in the following functions: +;; +;; (track-changes-register SIGNAL &key NOBEFORE DISJOINT IMMEDIATE) +;; (track-changes-fetch ID FUNC) +;; (track-changes-unregister ID) +;; +;; A typical use case might look like: +;; +;; (defvar my-foo--change-tracker nil) +;; (define-minor-mode my-foo-mode +;; "Fooing like there's no tomorrow." +;; (if (null my-foo-mode) +;; (when my-foo--change-tracker +;; (track-changes-unregister my-foo--change-tracker) +;; (setq my-foo--change-tracker nil)) +;; (unless my-foo--change-tracker +;; (setq my-foo--change-tracker +;; (track-changes-register +;; (lambda (id) +;; (track-changes-fetch +;; id (lambda (beg end before) +;; ..DO THE THING..)))))))) + +;;; News: + +;; Since v1.1: +;; +;; - New function `track-changes-inconsistent-state-p'. + +;;; Code: + +;; Random ideas: +;; - We could let trackers specify a function to record auxiliary info +;; about a state. This would be called from the first before-c-f +;; and then provided to FUNC. TeXpresso could use it to avoid needing +;; the BEFORE string: it could record the total number of bytes +;; in the "before" state so that from `track-changes-fetch' it could +;; compute the number of bytes that used to be in BEG/END. +;; - We could also let them provide another function to run in +;; before-c-f to signal errors if the change is not acceptable, +;; but contrary to before-c-f it would be called only when we +;; move t-c--before-beg/end so it scales better when there are +;; many small changes. + +(require 'cl-lib) + +;;;; Internal types and variables. + +(cl-defstruct (track-changes--tracker + ;; (:noinline t) ;Requires Emacs≥27 + (:constructor nil) + (:constructor track-changes--tracker ( signal state + &optional + nobefore immediate))) + signal state nobefore immediate) + +(cl-defstruct (track-changes--state + ;; (:noinline t) ;Requires Emacs≥27 + (:constructor nil) + (:constructor track-changes--state ())) + "Object holding a description of a buffer state. +A buffer state is described by a BEG/END/BEFORE triplet which say how to +recover that state from the next state. I.e. if the buffer's contents +reflects the next state, you can recover the previous state by replacing +the BEG..END region with the BEFORE string. + +NEXT is the next state object (i.e. a more recent state). +If NEXT is nil it means it's the most recent state and it may be incomplete +\(BEG/END/BEFORE may be nil), in which case those fields will take their +values from `track-changes--before-(beg|end|before)' when the next +state is created." + (beg (point-max)) + (end (point-min)) + (before nil) + (next nil)) + +(defvar-local track-changes--trackers () + "List of trackers currently registered in the buffer.") +(defvar-local track-changes--clean-trackers () + "List of trackers that are clean. +Those are the trackers that get signaled when a change is made.") + +(defvar-local track-changes--disjoint-trackers () + "List of trackers that want to react to disjoint changes. +These trackers are signaled every time track-changes notices +that some upcoming changes touch another \"distant\" part of the buffer.") + +(defvar-local track-changes--state nil) + +;; `track-changes--before-*' keep track of the content of the +;; buffer when `track-changes--state' was cleaned. +(defvar-local track-changes--before-beg 0 + "Beginning position of the remembered \"before string\".") +(defvar-local track-changes--before-end 0 + "End position of the text replacing the \"before string\".") +(defvar-local track-changes--before-string "" + "String holding some contents of the buffer before the current change. +This string is supposed to cover all the already modified areas plus +the upcoming modifications announced via `before-change-functions'. +If all trackers are `nobefore', then this holds the `buffer-size' before +the current change.") +(defvar-local track-changes--before-no t + "If non-nil, all the trackers are `nobefore'. +Should be equal to (memq #\\='track-changes--before before-change-functions).") + +(defvar-local track-changes--before-clean 'unset + "Status of `track-changes--before-*' vars. +More specifically it indicates which \"before\" they hold. +- nil: The vars hold the \"before\" info of the current state. +- `unset': The vars hold the \"before\" info of some older state. + This is what it is set to right after creating a fresh new state. +- `set': Like nil but the state is still clean because the buffer has not + been modified yet. This is what it is set to after the first + `before-change-functions' but before an `after-change-functions'.") + +(defvar-local track-changes--buffer-size nil + "Current size of the buffer, as far as this library knows. +This is used to try and detect cases where buffer modifications are \"lost\".") + +;;;; Exposed API. + +(defvar track-changes-record-errors + ;; By default, record errors only for non-release versions, because we + ;; presume that these might be too old to receive fixes, so better not + ;; annoy the user too much about errors. + (string-match "\\..*\\." emacs-version) + "If non-nil, keep track of errors in `before/after-chage-functions' calls. +The errors are kept in `track-changes--error-log'.") + +(cl-defun track-changes-register ( signal &key nobefore disjoint immediate) + "Register a new tracker whose change-tracking function is SIGNAL. +Return the ID of the new tracker. + +SIGNAL is a function that will be called with one argument (the tracker ID) +after the current buffer is modified, so that it can react to the change. +Once called, SIGNAL is not called again until `track-changes-fetch' +is called with the corresponding tracker ID. + +If optional argument NOBEFORE is non-nil, it means that this tracker does +not need the BEFORE strings (it will receive their size instead). + +If optional argument DISJOINT is non-nil, SIGNAL is called every time just +before combining changes from \"distant\" parts of the buffer. +This is needed when combining disjoint changes into one bigger change +is unacceptable, typically for performance reasons. +These calls are distinguished from normal calls by calling SIGNAL with +a second argument which is the distance between the upcoming change and +the previous changes. +BEWARE: In that case SIGNAL is called directly from `before-change-functions' +and should thus be extra careful: don't modify the buffer, don't call a function +that may block, ... +In order to prevent the upcoming change from being combined with the previous +changes, SIGNAL needs to call `track-changes-fetch' before it returns. + +By default SIGNAL is called after a change via a 0 seconds timer. +If optional argument IMMEDIATE is non-nil it means SIGNAL should be called +as soon as a change is detected, +BEWARE: In that case SIGNAL is called directly from `after-change-functions' +and should thus be extra careful: don't modify the buffer, don't call a function +that may block, do as little work as possible, ... +When IMMEDIATE is non-nil, the SIGNAL should probably not always call +`track-changes-fetch', since that would defeat the purpose of this library." + (when (and nobefore disjoint) + ;; FIXME: Without `before-change-functions', we can discover + ;; a disjoint change only after the fact, which is not good enough. + ;; But we could use a stripped down before-change-function, + (error "`disjoint' not supported for `nobefore' trackers")) + (track-changes--clean-state) + (unless nobefore + (setq track-changes--before-no nil) + (add-hook 'before-change-functions #'track-changes--before nil t)) + (add-hook 'after-change-functions #'track-changes--after nil t) + (let ((tracker (track-changes--tracker signal track-changes--state + nobefore immediate))) + (push tracker track-changes--trackers) + (push tracker track-changes--clean-trackers) + (when disjoint + (push tracker track-changes--disjoint-trackers)) + tracker)) + +(defun track-changes-unregister (id) + "Remove the tracker denoted by ID. +Trackers can consume resources (especially if `track-changes-fetch' is +not called), so it is good practice to unregister them when you don't +need them any more." + (unless (memq id track-changes--trackers) + (error "Unregistering a non-registered tracker: %S" id)) + (setq track-changes--trackers (delq id track-changes--trackers)) + (setq track-changes--clean-trackers (delq id track-changes--clean-trackers)) + (setq track-changes--disjoint-trackers + (delq id track-changes--disjoint-trackers)) + (when (cl-every #'track-changes--tracker-nobefore track-changes--trackers) + (setq track-changes--before-no t) + (remove-hook 'before-change-functions #'track-changes--before t)) + (when (null track-changes--trackers) + (mapc #'kill-local-variable + '(track-changes--before-beg + track-changes--before-end + track-changes--before-string + track-changes--buffer-size + track-changes--before-clean + track-changes--state)) + (remove-hook 'after-change-functions #'track-changes--after t))) + +(defun track-changes-fetch (id func) + "Fetch the pending changes for tracker ID pass them to FUNC. +ID is the tracker ID returned by a previous `track-changes-register'. +FUNC is a function. It is called with 3 arguments (BEGIN END BEFORE) +where BEGIN..END delimit the region that was changed since the last +time `track-changes-fetch' was called and BEFORE is a string containing +the previous content of that region (or just its length as an integer +if the tracker ID was registered with the `nobefore' option). +If track-changes detected that some changes were missed, then BEFORE will +be the symbol `error' to indicate that the buffer got out of sync. +This reflects a bug somewhere, so please report it when it happens. + +If no changes occurred since the last time, it doesn't call FUNC and +returns nil, otherwise it returns the value returned by FUNC +and re-enable the TRACKER corresponding to ID." + (cl-assert (memq id track-changes--trackers)) + (unless (equal track-changes--buffer-size (buffer-size)) + (track-changes--recover-from-error)) + (let ((beg nil) + (end nil) + (before t) + (lenbefore 0) + (states ())) + ;; Transfer the data from `track-changes--before-string' + ;; to the tracker's state object, if needed. + (track-changes--clean-state) + ;; We want to combine the states from most recent to oldest, + ;; so reverse them. + (let ((state (track-changes--tracker-state id))) + (while state + (push state states) + (setq state (track-changes--state-next state)))) + + (cond + ((eq (car states) track-changes--state) + (cl-assert (null (track-changes--state-before (car states)))) + (setq states (cdr states))) + (t + ;; The states are disconnected from the latest state because + ;; we got out of sync! + (cl-assert (eq (track-changes--state-before (car states)) 'error)) + (setq beg (point-min)) + (setq end (point-max)) + (setq before 'error) + (setq states nil))) + + (dolist (state states) + (let ((prevbeg (track-changes--state-beg state)) + (prevend (track-changes--state-end state)) + (prevbefore (track-changes--state-before state))) + (if (eq before t) + (progn + ;; This is the most recent change. Just initialize the vars. + (setq beg prevbeg) + (setq end prevend) + (setq lenbefore + (if (stringp prevbefore) (length prevbefore) prevbefore)) + (setq before + (unless (track-changes--tracker-nobefore id) prevbefore))) + (let ((endb (+ beg lenbefore))) + (when (< prevbeg beg) + (if (not before) + (setq lenbefore (+ (- beg prevbeg) lenbefore)) + (setq before + (concat (buffer-substring-no-properties + prevbeg beg) + before)) + (setq lenbefore (length before))) + (setq beg prevbeg) + (cl-assert (= endb (+ beg lenbefore)))) + (when (< endb prevend) + (let ((new-end (+ end (- prevend endb)))) + (if (not before) + (setq lenbefore (+ lenbefore (- new-end end))) + (setq before + (concat before + (buffer-substring-no-properties + end new-end))) + (setq lenbefore (length before))) + (setq end new-end) + (cl-assert (= prevend (+ beg lenbefore))) + (setq endb (+ beg lenbefore)))) + (cl-assert (<= beg prevbeg prevend endb)) + ;; The `prevbefore' is covered by the new one. + (if (not before) + (setq lenbefore + (+ (- prevbeg beg) + (if (stringp prevbefore) + (length prevbefore) prevbefore) + (- endb prevend))) + (setq before + (concat (substring before 0 (- prevbeg beg)) + prevbefore + (substring before (- (length before) + (- endb prevend))))) + (setq lenbefore (length before))))))) + (unwind-protect + (if (null beg) + (progn + (cl-assert (null states)) + ;; We may have been called in the middle of another + ;; `track-changes-fetch', in which case we may be in a clean + ;; state but not yet on `track-changes--clean-trackers' + ;;(cl-assert (memq id track-changes--clean-trackers)) + (cl-assert (eq (track-changes--tracker-state id) + track-changes--state)) + ;; Nothing to do. + nil) + (cl-assert (not (memq id track-changes--clean-trackers))) + (cl-assert (<= (point-min) beg end (point-max))) + ;; Update the tracker's state *before* running `func' so we don't risk + ;; mistakenly replaying the changes in case `func' exits non-locally. + (setf (track-changes--tracker-state id) track-changes--state) + (funcall func beg end (or before lenbefore))) + ;; Re-enable the tracker's signal only after running `func', so + ;; as to avoid nested invocations. + (cl-pushnew id track-changes--clean-trackers)))) + +(defun track-changes-inconsistent-state-p () + "Return whether the current buffer is in an inconsistent state. +Ideally `before/after-change-functions' should be called for each and every +buffer change, but some packages make transient changes without +running those hooks. +This function tries to detect those situations so clients can decide +to postpone their work to a later time when the buffer is hopefully +returned to a consistent state." + (or (not (equal track-changes--buffer-size (buffer-size))) + inhibit-modification-hooks)) + +;;;; Auxiliary functions. + +(defun track-changes--clean-state () + (cond + ((null track-changes--state) + (cl-assert track-changes--before-clean) + (cl-assert (null track-changes--buffer-size)) + ;; No state has been created yet. Do it now. + (setq track-changes--buffer-size (buffer-size)) + (when track-changes--before-no + (setq track-changes--before-string (buffer-size))) + (setq track-changes--state (track-changes--state))) + (track-changes--before-clean + ;; If the state is already clean, there's nothing to do. + nil) + (t + (cl-assert (<= (track-changes--state-beg track-changes--state) + (track-changes--state-end track-changes--state))) + (let ((actual-beg (track-changes--state-beg track-changes--state)) + (actual-end (track-changes--state-end track-changes--state))) + (if track-changes--before-no + (progn + (cl-assert (integerp track-changes--before-string)) + (setf (track-changes--state-before track-changes--state) + (- track-changes--before-string + (- (buffer-size) (- actual-end actual-beg)))) + (setq track-changes--before-string (buffer-size))) + (cl-assert (<= track-changes--before-beg + actual-beg actual-end + track-changes--before-end)) + (cl-assert (null (track-changes--state-before track-changes--state))) + ;; The `track-changes--before-*' vars can cover more text than the + ;; actually modified area, so trim it down now to the relevant part. + (unless (= (- track-changes--before-end track-changes--before-beg) + (- actual-end actual-beg)) + (setq track-changes--before-string + (substring track-changes--before-string + (- actual-beg track-changes--before-beg) + (- (length track-changes--before-string) + (- track-changes--before-end actual-end)))) + (setq track-changes--before-beg actual-beg) + (setq track-changes--before-end actual-end)) + (setf (track-changes--state-before track-changes--state) + track-changes--before-string))) + ;; Note: We preserve `track-changes--before-*' because they may still + ;; be needed, in case `after-change-functions' are run before the next + ;; `before-change-functions'. + ;; Instead, we set `track-changes--before-clean' to `unset' to mean that + ;; `track-changes--before-*' can be reset at the next + ;; `before-change-functions'. + (setq track-changes--before-clean 'unset) + (let ((new (track-changes--state))) + (setf (track-changes--state-next track-changes--state) new) + (setq track-changes--state new))))) + +(defvar track-changes--error-log () + "List of errors encountered. +Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") + +(defun track-changes--recover-from-error () + ;; We somehow got out of sync. This is usually the result of a bug + ;; elsewhere that causes the before-c-f and after-c-f to be improperly + ;; paired, or to be skipped altogether. + ;; Not much we can do, other than force a full re-synchronization. + (if (not track-changes-record-errors) + (message "Recovering from confusing calls to `before/after-change-functions'!") + (warn "Missing/incorrect calls to `before/after-change-functions'!! +Details logged to `track-changes--error-log'") + (push (list (buffer-name) + (let* ((bf (backtrace-frames + #'track-changes--recover-from-error)) + (tail (nthcdr 50 bf))) + (when tail (setcdr tail '...)) + bf) + (let ((rk (recent-keys 'include-cmds))) + (if (< (length rk) 20) rk (substring rk -20)))) + track-changes--error-log)) + (setq track-changes--before-clean 'unset) + (setq track-changes--buffer-size (buffer-size)) + ;; Create a new state disconnected from the previous ones! + ;; Mark the previous one as junk, just to be clear. + (setf (track-changes--state-before track-changes--state) 'error) + (setq track-changes--state (track-changes--state))) + +(defun track-changes--before (beg end) + (cl-assert track-changes--state) + (cl-assert (<= beg end)) + (let* ((size (- end beg)) + (reset (lambda () + (cl-assert track-changes--before-clean) + (setq track-changes--before-clean 'set) + (setf track-changes--before-string + (buffer-substring-no-properties beg end)) + (setf track-changes--before-beg beg) + (setf track-changes--before-end end))) + + (signal-if-disjoint + (lambda (pos1 pos2) + (let ((distance (- pos2 pos1))) + (when (> distance + ;; If the distance is smaller than the size of the + ;; current change, then we may as well consider it + ;; as "near". + (max (length track-changes--before-string) + size + (- track-changes--before-end + track-changes--before-beg))) + (dolist (tracker track-changes--disjoint-trackers) + (funcall (track-changes--tracker-signal tracker) + tracker distance)) + ;; Return non-nil if the state was cleaned along the way. + track-changes--before-clean))))) + + (if track-changes--before-clean + (progn + ;; Detect disjointness with previous changes here as well, + ;; so that if a client calls `track-changes-fetch' all the time, + ;; it doesn't prevent others from getting a disjointness signal. + (when (and track-changes--before-beg + (let ((found nil)) + (dolist (tracker track-changes--disjoint-trackers) + (unless (memq tracker track-changes--clean-trackers) + (setq found t))) + found)) + ;; There's at least one `tracker' that wants to know about disjoint + ;; changes *and* it has unseen pending changes. + ;; FIXME: This can occasionally signal a tracker that's clean. + (if (< beg track-changes--before-beg) + (funcall signal-if-disjoint end track-changes--before-beg) + (funcall signal-if-disjoint track-changes--before-end beg))) + (funcall reset)) + (save-restriction + (widen) + (cl-assert (<= (point-min) + track-changes--before-beg + track-changes--before-end + (point-max))) + (when (< beg track-changes--before-beg) + (if (and track-changes--disjoint-trackers + (funcall signal-if-disjoint end track-changes--before-beg)) + (funcall reset) + (let* ((old-bbeg track-changes--before-beg) + ;; To avoid O(N²) behavior when faced with many small + ;; changes, we copy more than needed. + (new-bbeg + (min beg (max (point-min) + (- old-bbeg + (length track-changes--before-string)))))) + (setf track-changes--before-beg new-bbeg) + (cl-callf (lambda (old new) (concat new old)) + track-changes--before-string + (buffer-substring-no-properties new-bbeg old-bbeg))))) + + (when (< track-changes--before-end end) + (if (and track-changes--disjoint-trackers + (funcall signal-if-disjoint track-changes--before-end beg)) + (funcall reset) + (let* ((old-bend track-changes--before-end) + ;; To avoid O(N²) behavior when faced with many small + ;; changes, we copy more than needed. + (new-bend + (max end (min (point-max) + (+ old-bend + (length track-changes--before-string)))))) + (setf track-changes--before-end new-bend) + (cl-callf concat track-changes--before-string + (buffer-substring-no-properties old-bend new-bend))))))))) + +(defun track-changes--after (beg end len) + (cl-assert track-changes--state) + (and (eq track-changes--before-clean 'unset) + (not track-changes--before-no) + ;; This can be a sign that a `before-change-functions' went missing, + ;; or that we called `track-changes--clean-state' between + ;; a `before-change-functions' and `after-change-functions'. + (track-changes--before beg end)) + (setq track-changes--before-clean nil) + (let ((offset (- (- end beg) len))) + (cl-incf track-changes--before-end offset) + (cl-incf track-changes--buffer-size offset) + (if (not (or track-changes--before-no + (save-restriction + (widen) + (<= (point-min) + track-changes--before-beg + beg end + track-changes--before-end + (point-max))))) + ;; BEG..END is not covered by previous `before-change-functions'!! + (track-changes--recover-from-error) + ;; Note the new changes. + (when (< beg (track-changes--state-beg track-changes--state)) + (setf (track-changes--state-beg track-changes--state) beg)) + (cl-callf (lambda (old-end) (max end (+ old-end offset))) + (track-changes--state-end track-changes--state)) + (cl-assert (or track-changes--before-no + (<= track-changes--before-beg + (track-changes--state-beg track-changes--state) + beg end + (track-changes--state-end track-changes--state) + track-changes--before-end))))) + (while track-changes--clean-trackers + (let ((tracker (pop track-changes--clean-trackers))) + (if (track-changes--tracker-immediate tracker) + (funcall (track-changes--tracker-signal tracker) tracker) + (run-with-timer 0 nil #'track-changes--call-signal + (current-buffer) tracker))))) + +(defun track-changes--call-signal (buf tracker) + (when (buffer-live-p buf) + (with-current-buffer buf + ;; Silence ourselves if `track-changes-fetch' was called + ;; or the tracker was unregistered in the mean time. + (when (and (not (memq tracker track-changes--clean-trackers)) + (memq tracker track-changes--trackers)) + (funcall (track-changes--tracker-signal tracker) tracker))))) + +;;;; Extra candidates for the API. + +;; The functions below came up during the design of this library, but +;; I'm not sure if they're worth the trouble or not, so for now I keep +;; them here (with a "--" in the name) for documentation. --Stef + +;; This could be a good alternative to using a temp-buffer like in +;; `eglot--virtual-pos-to-lsp-position': since presumably we've just +;; been changing this very area of the buffer, the gap should be +;; ready nearby, so the operation should be fairly cheap, while +;; giving you the comfort of having access to the *full* buffer text. +;; +;; It may seem silly to go back to the previous state, since we could have +;; used `before-change-functions' to run FUNC right then when we were in +;; that state. The advantage is that with track-changes we get to decide +;; retroactively which state is the one for which we want to call FUNC and +;; which BEG..END to use: when that state was current we may have known +;; then that it would be "the one" but we didn't know what BEG and END +;; should be because those depend on the changes that came afterwards. +(defun track-changes--in-revert (beg end before func) + "Call FUNC with the buffer contents temporarily reverted to BEFORE. +FUNC is called with no arguments and with point right after BEFORE. +FUNC is not allowed to modify the buffer and it should refrain from using +operations that use a cache populated from the buffer's content, +such as `syntax-ppss'." + (catch 'track-changes--exit + (with-silent-modifications ;; This has to be outside `atomic-change-group'. + (atomic-change-group + (goto-char end) + (insert-before-markers before) + (delete-region beg end) + (throw 'track-changes--exit + (let ((inhibit-read-only nil) + (buffer-read-only t)) + (funcall func))))))) + +;; This one is a cheaper version of (track-changes-fetch id #'ignore), +;; e.g. for clients that don't want to see their own changes. +(defun track-changes--reset (id) + "Mark all past changes as handled for tracker ID. +Re-arms ID's signal." + (track-changes--clean-state) + (setf (track-changes--tracker-state id) track-changes--state) + (cl-pushnew id track-changes--clean-trackers) + (cl-assert (not (track-changes--pending-p id)))) + +(defun track-changes--pending-p (id) + "Return non-nil if there are pending changes for tracker ID." + (or (not track-changes--before-clean) + (track-changes--state-next id))) + +(defmacro with--track-changes (id vars &rest body) + (declare (indent 2) (debug (form sexp body))) + `(track-changes-fetch ,id (lambda ,vars ,@body))) + +(provide 'track-changes) +;;; track-changes.el ends here diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 6c62a56e99c..68db33bfa68 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -120,6 +120,14 @@ so only the element (FOO) will match it. See also `warning-suppress-log-types'." :type '(repeat (repeat symbol)) :version "22.1") + +(defcustom warning-display-at-bottom t + "Display the warning buffer at the bottom of the screen. +The output window will be scrolled to the bottom of the buffer +to show the last warning message." + :type 'boolean + :version "30.1") + ;; The autoload cookie is so that programs can bind this variable ;; safely, testing the existing value, before they call one of the @@ -225,10 +233,14 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress." (?q "quit and do nothing")))) (?y (customize-save-variable 'warning-suppress-log-types - (cons (list type) warning-suppress-log-types))) + (if (consp type) + (cons type warning-suppress-log-types) + (cons (list type) warning-suppress-log-types)))) (?n (customize-save-variable 'warning-suppress-types - (cons (list type) warning-suppress-types))) + (if (consp type) + (cons type warning-suppress-types) + (cons (list type) warning-suppress-types)))) (_ (message "Exiting")))) ;;;###autoload @@ -358,10 +370,21 @@ entirely by setting `warning-suppress-types' or (or (< (warning-numeric-level level) (warning-numeric-level warning-minimum-level)) (warning-suppress-p type warning-suppress-types) - (let ((window (display-buffer buffer))) - (when (and (markerp warning-series) + (let ((window (display-buffer + buffer + (when warning-display-at-bottom + '(display-buffer--maybe-at-bottom + (window-height . (lambda (window) + (fit-window-to-buffer window 10))) + (category . warning)))))) + (when (and window (markerp warning-series) (eq (marker-buffer warning-series) buffer)) (set-window-start window warning-series)) + (when (and window warning-display-at-bottom) + (with-selected-window window + (goto-char (point-max)) + (forward-line -1) + (recenter -1))) (sit-for 0))))))))) ;; Use \\<special-mode-map> so that help-enable-autoload can do its thing. diff --git a/lisp/env.el b/lisp/env.el index e0a8df8476c..7d0c7dd0126 100644 --- a/lisp/env.el +++ b/lisp/env.el @@ -207,7 +207,8 @@ parameter. Otherwise, this function searches `process-environment' for VARIABLE. If it is not found there, then it continues the search in the environment list of the selected frame." - (declare (side-effect-free t)) + (declare (type (function (string &optional frame) (or null string))) + (side-effect-free t)) (interactive (list (read-envvar-name "Get environment variable: " t))) (let ((value (getenv-internal (if (multibyte-string-p variable) (encode-coding-string diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 9fc8a4d29f4..ab419d2b018 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -102,6 +102,7 @@ (require 'erc-common) (defvar erc--display-context) +(defvar erc--msg-prop-overrides) (defvar erc--target) (defvar erc-channel-list) (defvar erc-channel-members) @@ -787,7 +788,8 @@ TLS (see `erc-session-client-certificate' for more details)." ;; MOTD line) (if (eq (process-status process) 'connect) ;; waiting for a non-blocking connect - keep the user informed - (progn + (let ((erc--msg-prop-overrides `((erc--skip . (stamp)) + ,@erc--msg-prop-overrides))) (erc-display-message nil nil buffer "Opening connection..\n") (run-at-time 1 nil erc--server-connect-function process)) (message "%s...done" msg) @@ -1536,6 +1538,8 @@ Finds hooks by looking in the `erc-server-responses' hash table." (let ((hook (or (erc-get-hook (erc-response.command message)) 'erc-default-server-functions))) (run-hook-with-args-until-success hook process message) + ;; Some handlers, like `erc-cmd-JOIN', open new targets without + ;; saving excursion, and `erc-open' sets the current buffer. (erc-with-server-buffer (run-hook-with-args 'erc-timer-hook (erc-current-time))))) @@ -1992,7 +1996,6 @@ like `erc-insert-modify-hook'.") (and erc-ignore-reply-list (erc-ignored-reply-p msg tgt proc))) (when erc-minibuffer-ignored (message "Ignored %s from %s to %s" cmd sender-spec tgt)) - (defvar erc--msg-prop-overrides) (let* ((sndr (erc-parse-user sender-spec)) (nick (nth 0 sndr)) (login (nth 1 sndr)) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 4b4930e5bff..1f9d6fd64c0 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -830,7 +830,6 @@ argument when calling `erc-display-message'. Otherwise, add it to STRINGS. If STRINGS contains any trailing non-nil non-strings, concatenate leading string members before applying `format'. Otherwise, just concatenate everything." - (defvar erc-stamp--skip) (let* ((buffer (if (bufferp maybe-buffer) maybe-buffer (when (stringp maybe-buffer) @@ -847,9 +846,11 @@ non-strings, concatenate leading string members before applying #'format)) (string (apply op strings)) ;; Avoid timestamps unless left-sided. - (erc-stamp--skip (or (bound-and-true-p erc-stamp--display-margin-mode) - (not (fboundp 'erc-timestamp-offset)) - (zerop (erc-timestamp-offset)))) + (skipp (or (bound-and-true-p erc-stamp--display-margin-mode) + (not (fboundp 'erc-timestamp-offset)) + (zerop (erc-timestamp-offset)))) + (erc--msg-prop-overrides `(,@(and skipp `((erc--skip stamp))) + ,@erc--msg-prop-overrides)) (erc-insert-post-hook (cons (lambda () (setq string (buffer-substring (point-min) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 8388efe062c..4115e314b39 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -617,6 +617,15 @@ the resulting variables will end up with more useful doc strings." "Return position of CHAR in STRING or nil if not found." (inline-quote (string-search (string ,char) ,string))) +(define-inline erc--solo (list-or-atom) + "If LIST-OR-ATOM is a list of one element, return that element. +Otherwise, return LIST-OR-ATOM." + (inline-letevals (list-or-atom) + (inline-quote + (if (and (consp ,list-or-atom) (null (cdr ,list-or-atom))) + (car ,list-or-atom) + ,list-or-atom)))) + (defmacro erc--doarray (spec &rest body) "Map over ARRAY, running BODY with VAR bound to iteration element. Behave more or less like `seq-doseq', but tailor operations for diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index aa12b807fbc..b2c8c991c96 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -274,16 +274,10 @@ merged messages, see option `erc-fill-wrap-merge-indicator'." (defcustom erc-fill-wrap-merge-indicator nil "Indicator to help distinguish between merged messages. Only matters when the option `erc-fill-wrap-merge' is enabled. -If the first element is the symbol `pre', ERC uses this option to -generate a replacement for the speaker's name tag. If the first -element is `post', ERC affixes a short string to the end of the -previous message. In either case, the second element should be a -character, like ?>, and the last element a valid face. In -special cases, you may also specify a cons of either -aforementioned symbol and a string, which tells ERC not to manage -the process for you. If unsure, try either of the first two -presets, both of which replace a continued speaker's name with a -dot-product-like character in a `shadow'-like face. +If the value is a cons of a character, like ?>, and a valid face, +ERC generates a replacement for the speaker's name tag. The +first two presets replace a continued speaker's name with a +bullet-like character in `shadow' face. Note that as of ERC 5.6, this option is still experimental, and changing its value mid-session is not yet supported (though, if @@ -300,20 +294,14 @@ command." :type '(choice (const nil) (const :tag "Leading MIDDLE DOT (U+00B7) as speaker" - (pre #xb7 erc-fill-wrap-merge-indicator-face)) + (#xb7 . erc-fill-wrap-merge-indicator-face)) (const :tag "Leading MIDDLE DOT (U+00B7) sans gap" - (pre . #("\u00b7" 0 1 (font-lock-face - erc-fill-wrap-merge-indicator-face)))) + #("\u00b7" + 0 1 (font-lock-face erc-fill-wrap-merge-indicator-face))) (const :tag "Leading RIGHT-ANGLE BRACKET (>) as speaker" - (pre ?> erc-fill-wrap-merge-indicator-face)) - (const :tag "Trailing PARAGRAPH SIGN (U+00B6)" - (post #xb6 erc-fill-wrap-merge-indicator-face)) - (const :tag "Trailing TILDE (~)" - (post ?~ erc-fill-wrap-merge-indicator-face)) - (cons :tag "User-provided string (advanced)" - (choice (const pre) (const post)) string) - (list :tag "User-provided character-face pairing" - (choice (const pre) (const post)) character face))) + (?> . erc-fill-wrap-merge-indicator-face)) + (string :tag "User-provided string (advanced)") + (cons :tag "User-provided character-face pairing" character face))) (defun erc-fill--wrap-move (normal-cmd visual-cmd &rest args) (apply (pcase erc-fill--wrap-visual-keys @@ -330,24 +318,30 @@ command." ;; `kill-line' anyway so that users can see the error. (erc-fill--wrap-move #'kill-line #'kill-visual-line arg)) -(defun erc-fill--wrap-escape-hidden-speaker () +(defun erc-fill--wrap-escape-hidden-speaker (&optional old-point) "Move to start of message text when left of speaker. -Basically mimic what `move-beginning-of-line' does with invisible text." +Basically mimic what `move-beginning-of-line' does with invisible text. +Stay put if OLD-POINT lies within hidden region." (when-let ((erc-fill-wrap-merge) - (prop (get-text-property (point) 'display)) - ((or (equal prop "") (eq 'margin (car-safe (car-safe prop)))))) - (goto-char (text-property-not-all (point) (pos-eol) 'display prop)))) + (prop (get-text-property (point) 'erc-fill--wrap-merge)) + ((or (member prop '("" t)) + (eq 'margin (car-safe (car-safe prop))))) + (end (text-property-not-all (point) (pos-eol) + 'erc-fill--wrap-merge prop)) + ((or (null old-point) (>= old-point end)))) + (goto-char end))) (defun erc-fill--wrap-beginning-of-line (arg) "Defer to `move-beginning-of-line' or `beginning-of-visual-line'." (interactive "^p") - (let ((inhibit-field-text-motion t)) - (erc-fill--wrap-move #'move-beginning-of-line - #'beginning-of-visual-line arg)) - (if (get-text-property (point) 'erc-prompt) - (goto-char erc-input-marker) - ;; Mimic what `move-beginning-of-line' does with invisible text. - (erc-fill--wrap-escape-hidden-speaker))) + (let ((opoint (point))) + (let ((inhibit-field-text-motion t)) + (erc-fill--wrap-move #'move-beginning-of-line + #'beginning-of-visual-line arg)) + (if (get-text-property (point) 'erc-prompt) + (goto-char erc-input-marker) + (when erc-fill-wrap-merge + (erc-fill--wrap-escape-hidden-speaker opoint))))) (defun erc-fill--wrap-previous-line (&optional arg try-vscroll) "Move to ARGth previous logical or screen line." @@ -359,7 +353,8 @@ Basically mimic what `move-beginning-of-line' does with invisible text." (erc-fill--wrap-move (if visp #'previous-line #'previous-logical-line) #'previous-line arg try-vscroll)) - (erc-fill--wrap-escape-hidden-speaker))) + (when erc-fill-wrap-merge + (erc-fill--wrap-escape-hidden-speaker)))) (defun erc-fill--wrap-next-line (&optional arg try-vscroll) "Move to ARGth next logical or screen line." @@ -368,7 +363,9 @@ Basically mimic what `move-beginning-of-line' does with invisible text." erc-fill-wrap-force-screen-line-movement))) (erc-fill--wrap-move (if visp #'next-line #'next-logical-line) #'next-line - arg try-vscroll))) + arg try-vscroll) + (when erc-fill-wrap-merge + (erc-fill--wrap-escape-hidden-speaker)))) (defun erc-fill--wrap-end-of-line (arg) "Defer to `move-end-of-line' or `end-of-visual-line'." @@ -459,6 +456,28 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." " warning. See Info:\"(erc) Modules\" for more." (mapcar (lambda (s) (format "`%s'" s)) missing-deps))))) +(defun erc-fill--wrap-massage-legacy-indicator-type () + "Migrate obsolete 5.6-git `erc-fill-wrap-merge-indicator' format." + (pcase erc-fill-wrap-merge-indicator + (`(post . ,_) + (erc--warn-once-before-connect 'erc-fill-wrap-mode + "The option `erc-fill-wrap-merge-indicator' has changed. Unfortunately," + " the `post' variant and related presets are no longer available." + " Setting to nil for the current session. Apologies for the disruption." + (setq erc-fill-wrap-merge-indicator nil))) + (`(pre . ,(and (pred stringp) string)) + (erc--warn-once-before-connect 'erc-fill-wrap-mode + "The format of option `erc-fill-wrap-merge-indicator' has changed" + " from a cons of (pre . STRING) to STRING. Please update your settings." + " Changing temporarily to \"" string "\" for the current session.") + (setq erc-fill-wrap-merge-indicator string)) + (`(pre ,(and (pred characterp) char) ,face) + (erc--warn-once-before-connect 'erc-fill-wrap-mode + "The format of option `erc-fill-wrap-merge-indicator' has changed" + " from (pre CHAR FACE) to a cons of (CHAR . FACE). Please update" + " when possible. Changing temporarily to %S for the current session." + (setq erc-fill-wrap-merge-indicator (cons char face)))))) + ;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill) (define-erc-module fill-wrap nil "Fill style leveraging `visual-line-mode'. @@ -505,6 +524,8 @@ enabled when shutting down. To opt out of `scrolltobottom' specifically, disable its minor mode, `erc-scrolltobottom-mode', via `erc-fill-wrap-mode-hook'." ((erc-fill--wrap-ensure-dependencies) + (when erc-fill-wrap-merge-indicator + (erc-fill--wrap-massage-legacy-indicator-type)) (erc--restore-initialize-priors erc-fill-wrap-mode erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys erc-fill--wrap-value erc-fill-static-center @@ -536,7 +557,6 @@ via `erc-fill-wrap-mode-hook'." (kill-local-variable 'erc-fill--wrap-last-msg) (kill-local-variable 'erc--inhibit-prompt-display-property-p) (kill-local-variable 'erc-fill--wrap-merge-indicator-pre) - (kill-local-variable 'erc-fill--wrap-merge-indicator-post) (remove-hook 'erc--refresh-prompt-hook #'erc-fill--wrap-indent-prompt) (remove-hook 'erc-button--prev-next-predicate-functions @@ -612,50 +632,25 @@ to be disabled." "Whether to dedent speakers in CTCP \"ACTION\" lines.") (defvar-local erc-fill--wrap-merge-indicator-pre nil) -(defvar-local erc-fill--wrap-merge-indicator-post nil) - -;; To support `erc-fill-line-spacing' with the "post" variant, we'd -;; need to use a new "replacing" `display' spec value for each -;; insertion, and add a sentinel property alongside it atop every -;; affected newline, e.g., (erc-fill-eol-display START-POS), where -;; START-POS is the position of the newline in the replacing string. -;; Then, upon spotting this sentinel in `erc-fill' (and maybe -;; `erc-fill-wrap-refill-buffer'), we'd add `line-spacing' to the -;; corresponding `display' replacement, starting at START-POS. -(defun erc-fill--wrap-insert-merged-post () - "Add `display' property at end of previous line." - (save-excursion - (goto-char (point-min)) - (save-restriction - (widen) - (cl-assert (= ?\n (char-before (point)))) - (unless erc-fill--wrap-merge-indicator-post - (let ((option (cdr erc-fill-wrap-merge-indicator))) - (setq erc-fill--wrap-merge-indicator-post - (if (stringp option) - (concat option - (and (not (string-suffix-p "\n" option)) "\n")) - (propertize (concat (string (car option)) "\n") - 'font-lock-face (cadr option)))))) - (unless (eq (field-at-pos (- (point) 2)) 'erc-timestamp) - (put-text-property (1- (point)) (point) - 'display erc-fill--wrap-merge-indicator-post))) - 0)) (defun erc-fill--wrap-insert-merged-pre () - "Add `display' property in lieu of speaker." + "Add `display' text property to speaker. +Also cover region with text prop `erc-fill--wrap-merge' set to t." (if erc-fill--wrap-merge-indicator-pre (progn - (put-text-property (point-min) (point) 'display - (car erc-fill--wrap-merge-indicator-pre)) + (add-text-properties (point-min) (point) + (list 'display + (car erc-fill--wrap-merge-indicator-pre) + 'erc-fill--wrap-merge t)) (cdr erc-fill--wrap-merge-indicator-pre)) - (let* ((option (cdr erc-fill-wrap-merge-indicator)) + (let* ((option erc-fill-wrap-merge-indicator) (s (if (stringp option) (concat option) (concat (propertize (string (car option)) - 'font-lock-face (cadr option)) + 'font-lock-face (cdr option)) " ")))) - (put-text-property (point-min) (point) 'display s) + (add-text-properties (point-min) (point) + (list 'display s 'erc-fill--wrap-merge t)) (cdr (setq erc-fill--wrap-merge-indicator-pre (cons s (erc-fill--wrap-measure (point-min) (point)))))))) @@ -679,8 +674,6 @@ See `erc-fill-wrap-mode' for details." (skip-syntax-forward "^-") (forward-char) (cond ((eq msg-prop 'datestamp) - (when erc-fill--wrap-last-msg - (set-marker erc-fill--wrap-last-msg (point-min))) (save-excursion (goto-char (point-max)) (skip-chars-backward "\n") @@ -690,12 +683,11 @@ See `erc-fill-wrap-mode' for details." (delete-region (1- (point)) (point)))))) ((and erc-fill-wrap-merge (erc-fill--wrap-continued-message-p)) - (put-text-property (point-min) (point) - 'display "") + (add-text-properties + (point-min) (point) + '(display "" erc-fill--wrap-merge "")) (if erc-fill-wrap-merge-indicator - (pcase (car erc-fill-wrap-merge-indicator) - ('pre (erc-fill--wrap-insert-merged-pre)) - ('post (erc-fill--wrap-insert-merged-post))) + (erc-fill--wrap-insert-merged-pre) 0)) (t (erc-fill--wrap-measure (point-min) (point)))))))) @@ -731,10 +723,9 @@ stash and restore `erc-fill--wrap-last-msg' before doing so, in case this module's insert hooks run by way of the process filter. With REPAIRP, destructively fill gaps and re-merge speakers." (goto-char start) - (cl-assert (null erc-fill--wrap-rejigger-last-message)) - (setq erc-fill--wrap-merge-indicator-pre nil - erc-fill--wrap-merge-indicator-post nil) - (let (erc-fill--wrap-rejigger-last-message) + (setq erc-fill--wrap-merge-indicator-pre nil) + (let ((erc-fill--wrap-rejigger-last-message + erc-fill--wrap-rejigger-last-message)) (while-let (((< (point) finish)) (beg (if (get-text-property (point) 'line-prefix) @@ -745,12 +736,13 @@ With REPAIRP, destructively fill gaps and re-merge speakers." ;; If this is a left-side stamp on its own line. (remove-text-properties beg (1+ end) '(line-prefix nil wrap-prefix nil)) (when-let ((repairp) - (dbeg (text-property-not-all beg end 'display nil)) + (dbeg (text-property-not-all beg end + 'erc-fill--wrap-merge nil)) ((get-text-property (1+ dbeg) 'erc--speaker)) - (dval (get-text-property dbeg 'display)) - ((equal "" dval))) - (remove-text-properties - dbeg (text-property-not-all dbeg end 'display dval) '(display))) + (dval (get-text-property dbeg 'erc-fill--wrap-merge))) + (remove-list-of-text-properties + dbeg (text-property-not-all dbeg end 'erc-fill--wrap-merge dval) + '(display erc-fill--wrap-merge))) ;; This "should" work w/o `front-sticky' and `rear-nonsticky'. (let* ((pos (if-let (((eq 'erc-timestamp (field-at-pos beg))) (b (field-beginning beg)) @@ -798,9 +790,8 @@ like `erc-match-toggle-hidden-fools'." callback repair) (progress-reporter-done rep))))) -;; FIXME use own text property to avoid false positives. (defun erc-fill--wrap-merged-button-p (point) - (equal "" (get-text-property point 'display))) + (get-text-property point 'erc-fill--wrap-merge)) (defun erc-fill--wrap-nudge (arg) (when (zerop arg) diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 64f9ec42783..ccf65f15abd 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -59,7 +59,7 @@ ;; 2008/12 - erc-highlight-nicknames.el ;; First release from Andy Stewart ;; 2007/09 - erc-highlight-nicknames.el -;; Initial release by by André Riemann +;; Initial release by André Riemann ;; [1] <https://www.github.com/leathekd/erc-hl-nicks> ;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames> diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 92cb9075b5e..0881006ed77 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -22,6 +22,13 @@ ;;; Commentary: +;; As of ERC 5.6, this library's main module, `services', mainly +;; concerns itself with authenticating to legacy IRC servers. If your +;; server supports SASL or CERTFP, please use one of those instead. +;; See (info "(erc) client-certificate") and (info "(erc) SASL") for +;; details. Note that this library also contains the local module +;; `services-regain' as well as standalone utility functions. + ;; There are two ways to go about identifying yourself automatically to ;; NickServ with this module. The more secure way is to listen for identify ;; requests from the user NickServ. Another way is to identify yourself to @@ -37,10 +44,7 @@ ;; Usage: ;; -;; Put into your .emacs: -;; -;; (require 'erc-services) -;; (erc-services-mode 1) +;; Customize the option `erc-modules' to include `services'. ;; ;; Add your nickname and NickServ password to `erc-nickserv-passwords'. ;; Using the Libera.Chat network as an example: @@ -50,10 +54,7 @@ ;; ;; The default automatic identification mode is autodetection of NickServ ;; identify requests. Set the variable `erc-nickserv-identify-mode' if -;; you'd like to change this behavior. You can also change the way -;; automatic identification is handled by using: -;; -;; M-x erc-nickserv-identify-mode +;; you'd like to change this behavior. ;; ;; If you'd rather not identify yourself automatically but would like access ;; to the functions contained in this file, just load this file without @@ -309,21 +310,26 @@ Example of use: "/msg\\s-NickServ\\s-IDENTIFY\\s-\^_password" "NickServ@services.slashnet.org" "IDENTIFY" nil nil nil)) - "Alist of NickServer details, sorted by network. + "Alist of NickServer details, sorted by network. Every element in the list has the form - (SYMBOL NICKSERV REGEXP NICK KEYWORD USE-CURRENT ANSWER SUCCESS-REGEXP) - -SYMBOL is a network identifier, a symbol, as used in `erc-networks-alist'. -NICKSERV is the description of the nickserv in the form nick!user@host. -REGEXP is a regular expression matching the message from nickserv. -NICK is nickserv's nickname. Use nick@server where necessary/possible. -KEYWORD is the keyword to use in the reply message to identify yourself. -USE-CURRENT indicates whether the current nickname must be used when - identifying. -ANSWER is the command to use for the answer. The default is `privmsg'. -SUCCESS-REGEXP is a regular expression matching the message nickserv - sends when you've successfully identified. -The last two elements are optional." + (NETWORK SENDER INSTRUCT-RX NICK SUBCMD YOUR-NICK-P ANSWER SUCCESS-RX) + +NETWORK is a network identifier, a symbol, as used in `erc-networks-alist'. +SENDER is the exact nick!user@host \"source\" for \"NOTICE\" messages +indicating success or requesting that the user identify. +INSTRUCT-RX is a regular expression matching a \"NOTICE\" from the + services bot instructing the user to identify. It must be non-null + when the option `erc-nickserv-identify-mode' is set to `autodetect'. + When it's `both', and this field is non-null, ERC will forgo + identifying on nick changes and after connecting. +NICK is the nickname of the services bot to use when issuing commands. +SUBCMD is the bot command for identifying, typically \"IDENTIFY\". +YOUR-NICK-P indicates whether to send the user's current nickname before + their password when identifying. +ANSWER is the command to use for the answer. The default is \"PRIVMSG\". +SUCCESS-RX is a regular expression matching the message NickServ sends + when you've successfully identified. +The last two elements are optional, as are others, where implied." :type '(repeat (list :tag "Nickserv data" (symbol :tag "Network name") diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index a81a3869436..b156f61d5d9 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -566,9 +566,8 @@ The INDENT level is ignored." (defun erc-speedbar--reset-last-ran-on-timer () "Reset `erc-speedbar--last-ran'." (when speedbar-buffer - (with-suppressed-warnings ((obsolete buffer-local-value)) ; <=29 - (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer) - (current-time))))) + (with-current-buffer speedbar-buffer + (setq erc-speedbar--last-ran (current-time))))) ;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t) (define-erc-module nickbar nil @@ -578,10 +577,12 @@ show its buffer in an `erc-status-sidebar' window instead of a separate frame. When disabling, close the window or, with a negative prefix arg, destroy the session. -WARNING: this module may produce unwanted side effects, like the -raising of frames or the stealing of input focus. If you witness -such a thing and can reproduce it, please file a bug report with -\\[erc-bug]." +For controlling whether the speedbar window is selectable with +`other-window', see `erc-nickbar-toggle-nicknames-window-lock'. +Note that during initialization, this module may produce unwanted +side effects, like the raising of frames or the stealing of input +focus. If you witness such a thing and can reproduce it, please +file a bug report with \\[erc-bug]." ((add-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) (add-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert) (add-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer) @@ -638,8 +639,8 @@ such a thing and can reproduce it, please file a bug report with (defun erc-speedbar-toggle-nicknames-window-lock (arg) "Toggle whether nicknames window is selectable with \\[other-window]. -When arg is a number, lock the window if non-negative, otherwise -unlock." +When ARG is a number, lock the window if non-negative. Otherwise, +unlock the window." (interactive "P") (unless erc-nickbar-mode (user-error "`erc-nickbar-mode' inactive")) @@ -648,10 +649,14 @@ unlock." ((integerp arg) nil) (t (not (window-parameter window 'no-other-window)))))) + (with-current-buffer speedbar-buffer + (setq cursor-type (not val))) (set-window-parameter window 'no-other-window val) (unless (numberp arg) (message "nick-window: %s" (if val "protected" "selectable")))))) +(defalias 'erc-nickbar-toggle-nicknames-window-lock + #'erc-speedbar-toggle-nicknames-window-lock) ;;;; Nicks integration diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index bcb9b4aafef..fd137c0548a 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -202,7 +202,8 @@ from entering them and instead jump over them." (when-let ((priors (or erc--server-reconnecting erc--target-priors))) (dolist (var '(erc-timestamp-last-inserted erc-timestamp-last-inserted-left - erc-timestamp-last-inserted-right)) + erc-timestamp-last-inserted-right + erc-stamp--date-stamps)) (when-let (existing (alist-get var priors)) (set var existing))))) @@ -219,10 +220,7 @@ This becomes the message's `erc--ts' text property." (cl-defmethod erc-stamp--current-time :around () (or erc-stamp--current-time (cl-call-next-method))) -(defvar erc-stamp--skip nil - "Non-nil means inhibit `erc-add-timestamp' completely.") - -(defvar erc-stamp--allow-unmanaged nil +(defvar erc-stamp--allow-unmanaged-p nil "Non-nil means run `erc-add-timestamp' almost unconditionally. This is an unofficial escape hatch for code wanting to use lower-level message-insertion functions, like `erc-insert-line', @@ -242,9 +240,11 @@ known via \\[erc-bug].") This function is meant to be called from `erc-insert-modify-hook' or `erc-send-modify-hook'." - (unless (or erc-stamp--skip (and (not erc-stamp--allow-unmanaged) - (null erc--msg-props))) - (let* ((ct (erc-stamp--current-time)) + (unless (and (not erc-stamp--allow-unmanaged-p) + (or (null erc--msg-props) + (erc--memq-msg-prop 'erc--skip 'stamp))) + (let* ((ct (or (erc--check-msg-prop 'erc--ts) + (erc-stamp--current-time))) (invisible (get-text-property (point-min) 'invisible)) (erc-stamp--invisible-property ;; FIXME on major version bump, make this `erc-' prefixed. @@ -652,7 +652,7 @@ printed just after each line's text (no alignment)." (erc-put-text-property from (1+ (point)) 'cursor-intangible t))))) (defvar erc-stamp--insert-date-hook nil - "Functions appended to send and modify hooks when inserting date stamp.") + "Hook run when inserting a date stamp.") (defvar-local erc-stamp--date-format-end nil "Tristate value indicating how and whether date stamps have been set up. @@ -661,9 +661,27 @@ stamps. An integer marks the `substring' TO parameter for truncating `erc-timestamp-format-left' prior to rendering. A value of t means the option's value doesn't require trimming.") -(defun erc-stamp--propertize-left-date-stamp () +;; This struct and its namesake variable exist to assist in testing. +(cl-defstruct erc-stamp--date + "Data relevant to life cycle of date-stamp insertion." + ( ts (error "Missing `ts' field") :type (or cons integer) + :documentation "Time recorded by `erc-insert-timestamp-left-and-right'.") + ( str (error "Missing `str' field") :type string + :documentation "Stamp rendered by `erc-insert-timestamp-left-and-right'.") + ( fn nil :type (or null function) + :documentation "Deferred insertion function created by post-modify hook.") + ( marker (make-marker) :type marker + :documentation "Insertion marker.")) + +(defvar-local erc-stamp--deferred-date-stamp nil + "Active `erc-stamp--date' instance. +Non-nil between insertion-modification and \"done\" (or timer) hook.") + +(defvar-local erc-stamp--date-stamps nil + "List of stamps in the current buffer.") + +(defun erc-stamp--propertize-left-date-stamp (&rest _) (add-text-properties (point-min) (1- (point-max)) '(field erc-timestamp)) - (erc--hide-message 'timestamp) (run-hooks 'erc-stamp--insert-date-hook)) (defun erc-stamp--format-date-stamp (ct) @@ -680,6 +698,16 @@ value of t means the option's value doesn't require trimming.") 0 erc-stamp--date-format-end) erc-timestamp-format-left)))) +(defun erc-stamp--find-insertion-point (p target-time) + "Scan buffer backwards from P looking for TARGET-TIME. +Return P or, if found, a position less than P." + (while-let ((q (previous-single-property-change (1- p) 'erc--ts)) + (qq (erc--get-inserted-msg-beg q)) + (ts (get-text-property qq 'erc--ts)) + ((not (time-less-p ts target-time)))) + (setq p qq)) + p) + (defun erc-stamp-inserting-date-stamp-p () "Return non-nil if the narrowed buffer contains a date stamp. Expect to be called by members of `erc-insert-modify-hook' and @@ -687,75 +715,78 @@ Expect to be called by members of `erc-insert-modify-hook' and inserted is a date stamp." (erc--check-msg-prop 'erc--msg 'datestamp)) -;; Calling `erc-display-message' from within a hook it's currently -;; running is roundabout, but it's a definite means of ensuring hooks -;; can act on the date stamp as a standalone message to do things like -;; adjust invisibility props. -(defun erc-stamp--insert-date-stamp-as-phony-message (string) - (cl-assert (string-empty-p string)) - (setq string erc-timestamp-last-inserted-left) - (let ((erc-stamp--skip t) - (erc-insert-modify-hook `(,@erc-insert-modify-hook - erc-stamp--propertize-left-date-stamp)) - (erc--insert-line-function #'insert-before-markers) - ;; Don't run hooks that aren't expecting a narrowed buffer. - (erc-insert-pre-hook nil) - (erc-insert-done-hook nil)) - (erc-display-message nil nil (current-buffer) string))) - -(defun erc-stamp--lr-date-on-pre-modify (_) - (when-let (((not erc-stamp--skip)) - (ct (erc-stamp--current-time)) - (rendered (erc-stamp--format-date-stamp ct)) - ((not (string-equal rendered erc-timestamp-last-inserted-left))) - (erc-insert-timestamp-function - #'erc-stamp--insert-date-stamp-as-phony-message)) - (save-excursion - (save-restriction - (narrow-to-region (or erc--insert-marker erc-insert-marker) - (or erc--insert-marker erc-insert-marker)) - ;; Ensure all hooks, like `erc-stamp--insert-date-hook', only - ;; see the let-bound value below during `erc-add-timestamp'. - (setq erc-timestamp-last-inserted-left nil) - (let* ((aligned (erc-stamp--time-as-day ct)) - (erc-stamp--current-time aligned) - ;; Forget current `erc--cmd', etc. - (erc--msg-props (map-into `((erc--msg . datestamp)) - 'hash-table)) - (erc-timestamp-last-inserted-left rendered) - erc-timestamp-format erc-away-timestamp-format) - (erc-add-timestamp)) - (setq erc-timestamp-last-inserted-left rendered))))) - -;; This minor mode is just a placeholder and currently unhelpful for -;; managing complexity. A useful version would leave a marker during -;; post-modify hooks and then perform insertions (before markers) -;; during "done" hooks. This would enable completely decoupling from -;; and possibly deprecating `erc-insert-timestamp-left-and-right'. -;; However, doing this would require expanding the internal API to -;; include insertion and deletion handlers for twiddling and massaging -;; text properties based on context immediately after modifying text -;; earlier in a buffer (away from `erc-insert-marker'). Without such -;; handlers, things like "merged" `fill-wrap' speakers and invisible -;; messages may be damaged by buffer modifications. +(defun erc-stamp--defer-date-insertion-on-post-modify (hook-var) + "Schedule a date stamp to be inserted via HOOK-VAR. +Do so when `erc-stamp--deferred-date-stamp' and its `fn' slot are +non-nil." + (when-let ((data erc-stamp--deferred-date-stamp) + ((null (erc-stamp--date-fn data))) + (ct (erc-stamp--date-ts data)) + (rendered (erc-stamp--date-str data)) + (buffer (current-buffer)) + (symbol (make-symbol "erc-stamp--insert-date")) + (marker (setf (erc-stamp--date-marker data) (point-min-marker)))) + (setf (erc-stamp--date-fn data) symbol) + (fset symbol + (lambda (&rest _) + (remove-hook hook-var symbol) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq erc-stamp--date-stamps + (cl-sort (cons data erc-stamp--date-stamps) #'time-less-p + :key #'erc-stamp--date-ts)) + (setq erc-stamp--deferred-date-stamp nil) + (let* ((aligned (erc-stamp--time-as-day ct)) + (erc-stamp--current-time aligned) + (erc--msg-props (map-into '((erc--msg . datestamp) + (erc--skip track)) + 'hash-table)) + (erc-insert-post-hook + `(,(lambda () + (set-marker marker (point-min)) + (set-marker-insertion-type marker t) + (erc--hide-message 'timestamp)) + ,@erc-insert-post-hook)) + (erc-insert-timestamp-function + #'erc-stamp--propertize-left-date-stamp) + (pos (erc-stamp--find-insertion-point marker aligned)) + ;; + erc-timestamp-format erc-away-timestamp-format) + (erc--with-spliced-insertion pos + (erc-display-message nil nil (current-buffer) rendered)) + (setf (erc-stamp--date-ts data) aligned)) + (setq erc-timestamp-last-inserted-left rendered))))) + (add-hook hook-var symbol -90))) + +(defun erc-stamp--defer-date-insertion-on-post-insert () + (erc-stamp--defer-date-insertion-on-post-modify 'erc-timer-hook)) + +(defun erc-stamp--defer-date-insertion-on-post-send () + (erc-stamp--defer-date-insertion-on-post-modify 'erc-send-completed-hook)) + +;; This minor mode is hopefully just a placeholder because it's quite +;; unhelpful for managing complexity. A useful version would exist as +;; a standalone module to allow completely decoupling from and +;; possibly deprecating `erc-insert-timestamp-left-and-right'. (define-minor-mode erc-stamp--date-mode "Insert date stamps as standalone messages." :interactive nil (if erc-stamp--date-mode - (progn (add-hook 'erc-insert-pre-hook - #'erc-stamp--lr-date-on-pre-modify 10 t) - (add-hook 'erc-pre-send-functions - #'erc-stamp--lr-date-on-pre-modify 10 t)) + (progn + (add-hook 'erc-insert-post-hook + #'erc-stamp--defer-date-insertion-on-post-insert 0 t) + (add-hook 'erc-send-post-hook + #'erc-stamp--defer-date-insertion-on-post-send 0 t)) (kill-local-variable 'erc-timestamp-last-inserted-left) - (remove-hook 'erc-insert-pre-hook - #'erc-stamp--lr-date-on-pre-modify t) - (remove-hook 'erc-pre-send-functions - #'erc-stamp--lr-date-on-pre-modify t))) + (remove-hook 'erc-insert-post-hook + #'erc-stamp--defer-date-insertion-on-post-insert t) + (remove-hook 'erc-send-post-hook + #'erc-stamp--defer-date-insertion-on-post-send t))) (defvar erc-stamp-prepend-date-stamps-p nil "When non-nil, date stamps are not independent messages. -This flag restores pre-5.6 behavior in which date stamps formed -the leading portion of affected messages. Beware that enabling +This flag restores pre-5.6 behavior in which date stamps were +prepended to normal chat messages. Beware that enabling this degrades the user experience by causing 5.6+ features, like `fill-wrap', dynamic invisibility, etc., to malfunction. When non-nil, none of the newline twiddling mentioned in the doc @@ -775,26 +806,17 @@ in the latter (if any) as part of the `erc-timestamp' field. Allow the stamp's `invisible' property to span that same interval but also cover the previous newline, in order to satisfy folding requirements related to `erc-legacy-invisible-bounds-p'. -Additionally, ensure every date stamp is identifiable as such so -that internal modules can easily distinguish between other -left-sided stamps and date stamps inserted by this function." +Additionally, ensure every date stamp is identifiable as such via +the function `erc-stamp-inserting-date-stamp-p' so that internal +modules can easily distinguish between other left-sided stamps +and date stamps inserted by this function." (unless (or erc-stamp--date-format-end erc-stamp-prepend-date-stamps-p (and (or (null erc-timestamp-format-left) (string-empty-p ; compat (string-trim erc-timestamp-format-left "\n"))) (always (erc-stamp--date-mode -1)) (setq erc-stamp-prepend-date-stamps-p t))) - (erc-stamp--date-mode +1) - ;; Hooks used by ^ are the preferred means of inserting date - ;; stamps. But they'll never see this inaugural message, so it - ;; must be handled specially. - (let ((erc--insert-marker (point-min-marker)) - (end-marker (point-max-marker))) - (set-marker-insertion-type erc--insert-marker t) - (erc-stamp--lr-date-on-pre-modify nil) - (narrow-to-region erc--insert-marker end-marker) - (set-marker end-marker nil) - (set-marker erc--insert-marker nil))) + (erc-stamp--date-mode +1)) (let* ((ct (erc-stamp--current-time)) (ts-right (with-suppressed-warnings ((obsolete erc-timestamp-format-right)) @@ -805,12 +827,22 @@ left-sided stamps and date stamps inserted by this function." ;; "prepended" date stamps as well. However, since this is a ;; compatibility oriented code path, and pre-5.6 did no such ;; thing, better to punt. - (when-let ((erc-stamp-prepend-date-stamps-p) - (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) - ((not (string= ts-left erc-timestamp-last-inserted-left)))) - (goto-char (point-min)) - (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left) - (insert (setq erc-timestamp-last-inserted-left ts-left))) + (if-let ((erc-stamp-prepend-date-stamps-p) + (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) + ((not (string= ts-left erc-timestamp-last-inserted-left)))) + (progn + (goto-char (point-min)) + (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp + ts-left) + (insert (setq erc-timestamp-last-inserted-left ts-left))) + (when-let + (((null erc-stamp--deferred-date-stamp)) + (rendered (erc-stamp--format-date-stamp ct)) + ((not (string-equal rendered erc-timestamp-last-inserted-left))) + ((null (cl-find rendered erc-stamp--date-stamps + :test #'string= :key #'erc-stamp--date-str)))) + (setq erc-stamp--deferred-date-stamp + (make-erc-stamp--date :ts ct :str rendered)))) ;; insert right timestamp (let ((erc-timestamp-only-if-changed-flag t) (erc-timestamp-last-inserted erc-timestamp-last-inserted-right)) @@ -924,6 +956,8 @@ For `erc-hide-timestamps, modify `buffer-invisibility-spec'." (kill-local-variable 'erc-stamp--last-stamp) (kill-local-variable 'erc-timestamp-last-inserted) (kill-local-variable 'erc-timestamp-last-inserted-right) + (kill-local-variable 'erc-stamp--deferred-date-stamp) + (kill-local-variable 'erc-stamp--date-stamps) (kill-local-variable 'erc-stamp--date-format-end))) (defun erc-hide-timestamps () @@ -992,7 +1026,12 @@ with the option `erc-echo-timestamps', see the companion option (move-marker erc-last-saved-position (1- (point-max)))) (defun erc-stamp--reset-on-clear (pos) - "Forget last-inserted stamps when POS is at insert marker." + "Forget last-inserted stamps when POS is at insert marker. +And discard stale references in `erc-stamp--date-stamps'." + (when erc-stamp--date-stamps + (setq erc-stamp--date-stamps + (seq-filter (lambda (o) (> (erc-stamp--date-marker o) pos)) + erc-stamp--date-stamps))) (when (= pos (1- erc-insert-marker)) (when erc-stamp--date-mode (add-hook 'erc-stamp--insert-date-hook diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el index b7695651e4c..dcdef7cfafc 100644 --- a/lisp/erc/erc-status-sidebar.el +++ b/lisp/erc/erc-status-sidebar.el @@ -192,7 +192,7 @@ If NO-CREATION is non-nil, the window is not created." (set-window-parameter sidebar-window 'no-delete-other-windows t) ;; Don't cycle to this window with `other-window'. (set-window-parameter sidebar-window 'no-other-window t) - (internal-show-cursor sidebar-window nil) + (setq cursor-type nil) (set-window-fringes sidebar-window 0 0) ;; Set a custom display table so the window doesn't show a ;; truncation symbol when a channel name is too big. diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 04ee76a9349..40e83fff974 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -959,9 +959,6 @@ NEW-FACES has a cdr." (throw 'face candidate)))))) choice))) -(defvar erc-track--skipped-msgs '(datestamp) - "Values of `erc--msg' text prop to ignore.") - (defun erc-track-modified-channels () "Hook function for `erc-insert-post-hook'. Check if the current buffer should be added to the mode line as a @@ -980,8 +977,7 @@ the current buffer is in `erc-mode'." erc-track-exclude-types) ;; Skip certain non-server-sent messages. (and (not parsed) - (erc--check-msg-prop 'erc--msg - erc-track--skipped-msgs)))))) + (erc--memq-msg-prop 'erc--skip 'track)))))) ;; If the active buffer is not visible (not shown in a ;; window), and not to be excluded, determine the kinds of ;; faces used in the current message, and unless the user diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 0750463a4e7..c92fd42322a 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -181,11 +181,18 @@ as of ERC 5.6: 5.6, a ticks/hertz pair on Emacs 29 and above, and a \"list\" type otherwise; managed by the `stamp' module + - `erc--skip': list of symbols known to modules that indicate an + intent to skip or simplify module-specific processing + - `erc--ephemeral': a symbol prefixed by or matching a module name; indicates to other modules and members of modification hooks that the current message should not affect stateful operations, such as recording a channel's most recent speaker + - `erc--hide': a symbol or list of symbols added as an `invisible' + prop value to the entire message, starting *before* the preceding + newline and ending before the trailing newline + This is an internal API, and the selection of related helper utilities is fluid and provisional. As of ERC 5.6, see the functions `erc--check-msg-prop' and `erc--get-inserted-msg-prop'.") @@ -1588,7 +1595,7 @@ capabilities." (remove-hook hook fun t)) (fmakunbound fun) (funcall f proc parsed))) - (add-hook hook fun nil t) + (add-hook hook fun -95 t) fun)) (defun erc--warn-once-before-connect (mode-var &rest args) @@ -1640,7 +1647,7 @@ the process buffer." "Return non-nil if argument BUFFER is an ERC server buffer. If BUFFER is nil, use the current buffer. For historical reasons, also return non-nil for channel buffers the client has -parted or from which it's been kicked." +parted or been kicked from." (with-current-buffer (or buffer (current-buffer)) (and (eq major-mode 'erc-mode) (null (erc-default-target))))) @@ -1662,8 +1669,13 @@ If BUFFER is nil, the current buffer is used." (defun erc-query-buffer-p (&optional buffer) "Return non-nil if BUFFER is an ERC query buffer. -If BUFFER is nil, the current buffer is used." - (not (erc-channel-p (or buffer (current-buffer))))) +If BUFFER is nil, use the current buffer." + (and-let* ((target (if buffer + (progn (when (stringp buffer) + (setq buffer (get-buffer buffer))) + (buffer-local-value 'erc--target buffer)) + erc--target))) + (not (erc--target-channel-p target)))) (defun erc-ison-p (nick) "Return non-nil if NICK is online." @@ -3230,13 +3242,20 @@ a full refresh." (defun erc--check-msg-prop (prop &optional val) "Return PROP's value in `erc--msg-props' when populated. -If VAL is a list, return non-nil if PROP appears in VAL. If VAL -is otherwise non-nil, return non-nil if VAL compares `eq' to the -stored value. Otherwise, return the stored value." +If VAL is a list, return non-nil if PROP's value appears in VAL. If VAL +is otherwise non-nil, return non-nil if VAL compares `eq' to the stored +value. Otherwise, return the stored value." (and-let* ((erc--msg-props) (v (gethash prop erc--msg-props))) (if (consp val) (memq v val) (if val (eq v val) v)))) +(defun erc--memq-msg-prop (prop needle) + "Return non-nil if msg PROP's value is a list containing NEEDLE." + (and-let* ((erc--msg-props) + (haystack (gethash prop erc--msg-props)) + ((consp haystack))) + (memq needle haystack))) + (defmacro erc--get-inserted-msg-beg-at (point at-start-p) (macroexp-let2* nil ((point point) (at-start-p at-start-p)) @@ -3278,14 +3297,36 @@ if not found." (and-let* ((stack-pos (erc--get-inserted-msg-beg (point)))) (get-text-property stack-pos prop))) -(defmacro erc--with-inserted-msg (&rest body) - "Simulate narrowing performed for send and insert hooks, and run BODY. -Expect callers to know that this doesn't wrap BODY in -`with-silent-modifications' or bind a temporary `erc--msg-props'." - `(when-let ((bounds (erc--get-inserted-msg-bounds))) - (save-restriction - (narrow-to-region (car bounds) (1+ (cdr bounds))) - ,@body))) +;; FIXME improve this nascent "message splicing" facility to include a +;; means for modules to adjust inserted messages on either side of the +;; splice position as well as to modify the spliced-in message itself +;; before and after each insertion-related hook runs. Also add a +;; counterpart to `erc--with-spliced-insertion' for deletions. +(defvar erc--insert-line-splice-function + #'erc--insert-before-markers-transplanting-hidden + "Function to handle in-place insertions away from prompt. +Modules that display \"stateful\" messages, where one message's content +depends on prior messages, should advise this locally as needed.") + +(defmacro erc--with-spliced-insertion (marker-or-pos &rest body) + "In BODY, ensure `erc-insert-line' inserts messages at MARKER-OR-POS. +If MARKER-OR-POS is a marker, let it advance normally (and permanently) +with each insertion. Allow modules to influence insertion by binding +`erc--insert-line-function' to `erc--insert-line-splice-function' around +BODY. Note that as of ERC 5.6, this macro cannot handle multiple +successive calls to `erc-insert-line' in BODY, such as when replaying +a history backlog." + (declare (indent 1)) + (let ((marker (make-symbol "marker"))) + `(progn + (cl-assert (= ?\n (char-before ,marker-or-pos))) + (cl-assert (null erc--insert-line-function)) + (let* ((,marker (and (not (markerp ,marker-or-pos)) + (copy-marker ,marker-or-pos))) + (erc--insert-marker (or ,marker ,marker-or-pos)) + (erc--insert-line-function erc--insert-line-splice-function)) + (prog1 (progn ,@body) + (when ,marker (set-marker ,marker nil))))))) (defun erc--traverse-inserted (beg end fn) "Visit messages between BEG and END and run FN in narrowed buffer. @@ -3325,7 +3366,11 @@ that this flag and the behavior it restores may disappear at any time, so if you need them, please let ERC know with \\[erc-bug].") (defvar erc--insert-line-function nil - "When non-nil, an alterntive to `insert' for inserting messages.") + "When non-nil, an `insert'-like function for inserting messages. +Modules, like `fill-wrap', that leave a marker at the beginning of an +inserted message clearly want that marker to advance along with text +inserted at that position. This can be addressed by binding this +variable to `insert-before-markers' around calls to `display-message'.") (defvar erc--insert-marker nil "Internal override for `erc-insert-marker'.") @@ -3509,7 +3554,7 @@ also `erc-button-add-face'." end (next-single-property-change pos prop object to))))) (defun erc--remove-from-prop-value-list (from to prop val &optional object) - "Remove VAL from text prop value between FROM and TO. + "Remove VAL from text PROP value between FROM and TO. If current value is VAL itself, remove the property entirely. When VAL is a list, act as if this function were called repeatedly with VAL set to each of VAL's members." @@ -3573,19 +3618,45 @@ preceding newline to its last non-newline character.") (make-obsolete-variable 'erc-legacy-invisible-bounds-p "decremented interval now permanent" "30.1") +(defun erc--insert-before-markers-transplanting-hidden (string) + "Insert STRING before markers and migrate any `invisible' props. +Expect to be called with `point' at the start of an inserted message, +i.e., one with an `erc--msg' property. Check the message prop header +for invisibility props advertised via `erc--hide'. When found, remove +them from the previous newline, and add them to the newline suffixing +the inserted version of STRING." + (let* ((after (and (not erc-legacy-invisible-bounds-p) + (get-text-property (point) 'erc--hide))) + (before (and after (get-text-property (1- (point)) 'invisible))) + (a (and after (ensure-list after))) + (b (and before (ensure-list before))) + (new (and before (erc--solo (cl-intersection b a))))) + (when new + (erc--remove-from-prop-value-list (1- (point)) (point) 'invisible a)) + (prog1 (insert-before-markers string) + (when new + (erc--merge-prop (1- (point)) (point) 'invisible new))))) + (defun erc--hide-message (value) "Apply `invisible' text-property with VALUE to current message. Expect to run in a narrowed buffer during message insertion. Begin the invisible interval at the previous message's trailing newline and end before the current message's. If the preceding message ends in a double newline or there is no previous message, -don't bother including the preceding newline." +don't bother including the preceding newline. Additionally, +record VALUE as part of the `erc--hide' property in the +\"msg-props\" header." (if erc-legacy-invisible-bounds-p ;; Before ERC 5.6, this also used to add an `intangible' ;; property, but the docs say it's now obsolete. (erc--merge-prop (point-min) (point-max) 'invisible value) - (let ((beg (point-min)) + (let ((old-hide (erc--check-msg-prop 'erc--hide)) + (beg (point-min)) (end (point-max))) + (puthash 'erc--hide (if old-hide + `(,value . ,(ensure-list old-hide)) + value) + erc--msg-props) (save-restriction (widen) (when (or (<= beg 4) (= ?\n (char-before (- beg 2)))) @@ -3604,9 +3675,11 @@ Treat ARG in a manner similar to mode toggles defined by (when (or (not arg) (natnump arg)) (add-to-invisibility-spec prop)))) -(defun erc--delete-inserted-message (beg-or-point &optional end) +(defun erc--delete-inserted-message-naively (beg-or-point &optional end) "Remove message between BEG and END. -Expect BEG and END to match bounds as returned by the macro +Do this without updating messages on either side even if their +appearance was somehow influenced by the newly absent message. +Expect BEG and END to match bounds as returned by the function `erc--get-inserted-msg-bounds'. Ensure all markers residing at the start of the deleted message end up at the beginning of the subsequent message." @@ -3626,7 +3699,8 @@ subsequent message." -1)))))))) (defvar erc--ranked-properties - '(erc--msg erc--spkr erc--ts erc--cmd erc--ctcp erc--ephemeral)) + '( erc--msg erc--spkr erc--ts erc--skip + erc--cmd erc--hide erc--ctcp erc--ephemeral)) (defun erc--order-text-properties-from-hash (table) "Return a plist of text props from items in TABLE. @@ -4191,8 +4265,11 @@ If there's no letter spec, the input is interpreted as a number of seconds. If input is blank, this function returns nil. Otherwise it returns the time spec converted to a number of seconds." - (let ((period (string-trim - (read-string prompt nil 'erc--read-time-period-history)))) + (erc--decode-time-period + (string-trim (read-string prompt nil 'erc--read-time-period-history)))) + +(defun erc--decode-time-period (period) + (progn ; unprogn on next major refactor (cond ;; Blank input. ((zerop (length period)) @@ -4223,36 +4300,76 @@ returns the time spec converted to a number of seconds." (user-error "%s is not a valid time period" period)) (decoded-time-period time)))))) -(defun erc-cmd-IGNORE (&optional user) - "Ignore USER. This should be a regexp matching nick!user@host. -If no USER argument is specified, list the contents of `erc-ignore-list'." +(defun erc--format-time-period (secs) + "Return a string with hour/minute/second labels for duration in SECS." + (let* ((hours (floor secs 3600)) + (minutes (floor (mod secs 3600) 60)) + (seconds (mod secs 60))) + (cond ((>= secs 3600) (format "%dh%dm%ds" hours minutes (floor seconds))) + ((>= secs 60) (format "%dm%ds" minutes (floor seconds))) + (t (format "%ds" (floor seconds)))))) + +(defun erc--get-ignore-timer-args (inst) + ;; The `cl-struct' `pcase' pattern and `cl-struct-slot-value' emit + ;; warnings when compiling because `timer' is un-`:named'. + (when (and (timerp inst) + (eq (aref inst (cl-struct-slot-offset 'timer 'function)) + 'erc--unignore-user)) + (aref inst (cl-struct-slot-offset 'timer 'args)))) + +(defun erc--find-ignore-timer (&rest args) + "Find an existing ignore timer." + (cl-find args timer-list :key #'erc--get-ignore-timer-args :test #'equal)) + +(defun erc-cmd-IGNORE (&optional user timespec) + "Drop messages from senders, like nick!user@host, matching regexp USER. +With human-readable TIMESPEC, ignore messages from matched senders for +the specified duration, like \"20m\". Without USER, list the contents +of `erc-ignore-list'." (if user - (let ((quoted (regexp-quote user))) + (let ((quoted (regexp-quote user)) + (prompt "Add a timeout? (Blank for no, or a time spec like 2h): ") + timeout msg) (when (and (not (string= user quoted)) (y-or-n-p (format "Use regexp-quoted form (%s) instead? " quoted))) (setq user quoted)) - (let ((timeout - (erc--read-time-period - "Add a timeout? (Blank for no, or a time spec like 2h): ")) - (buffer (current-buffer))) + (unless timespec + (setq timespec + (read-string prompt nil 'erc--read-time-period-history))) + (setq timeout (erc--decode-time-period (string-trim timespec)) + msg (if timeout + (format "Now ignoring %s for %s" user + (erc--format-time-period timeout)) + (format "Now ignoring %s" user))) + (erc-with-server-buffer (when timeout - (run-at-time timeout nil - (lambda () - (erc--unignore-user user buffer)))) - (erc-display-message nil 'notice 'active - (format "Now ignoring %s" user)) - (erc-with-server-buffer (add-to-list 'erc-ignore-list user)))) + (if-let ((existing (erc--find-ignore-timer user (current-buffer)))) + (timer-set-time existing (timer-relative-time nil timeout)) + (run-at-time timeout nil #'erc--unignore-user user + (current-buffer)))) + (erc-display-message nil 'notice 'active msg) + (cl-pushnew user erc-ignore-list :test #'equal))) (if (null (erc-with-server-buffer erc-ignore-list)) (erc-display-message nil 'notice 'active "Ignore list is empty") (erc-display-message nil 'notice 'active "Ignore list:") - (mapc (lambda (item) - (erc-display-message nil 'notice 'active item)) - (erc-with-server-buffer erc-ignore-list)))) + (erc-with-server-buffer + (let ((seen (copy-sequence erc-ignore-list))) + (dolist (timer timer-list) + (when-let ((args (erc--get-ignore-timer-args timer)) + ((eq (current-buffer) (nth 1 args))) + (user (car args)) + (delta (- (timer-until timer (current-time)))) + (duration (erc--format-time-period delta))) + (setq seen (delete user seen)) + (erc-display-message nil 'notice 'active 'ignore-list + ?p user ?s duration))) + (dolist (pattern seen) + (erc-display-message nil 'notice 'active pattern)))))) t) (defun erc-cmd-UNIGNORE (user) - "Remove the user specified in USER from the ignore list." + "Remove the first pattern in `erc-ignore-list' matching USER." (let ((ignored-nick (car (erc-with-server-buffer (erc-member-ignore-case (regexp-quote user) erc-ignore-list))))) @@ -4264,16 +4381,18 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (erc-display-message nil 'notice 'active (format "%s is not currently ignored!" user)))) (when ignored-nick - (erc--unignore-user user (current-buffer)))) + (erc--unignore-user ignored-nick (erc-server-buffer)))) t) (defun erc--unignore-user (user buffer) (when (buffer-live-p buffer) (with-current-buffer buffer + (cl-assert (erc--server-buffer-p)) (erc-display-message nil 'notice 'active (format "No longer ignoring %s" user)) - (erc-with-server-buffer - (setq erc-ignore-list (delete user erc-ignore-list)))))) + (setq erc-ignore-list (delete user erc-ignore-list)) + (when-let ((existing (erc--find-ignore-timer user buffer))) + (cancel-timer existing))))) (defvar erc--pre-clear-functions nil "Abnormal hook run when truncating buffers. @@ -6016,7 +6135,8 @@ NUH, and the current `erc-response' object.") ;; The format strings in the following `-speaker' catalog shouldn't ;; contain any non-protocol words, so they make sense in any language. - +;; Note that the following definitions generally avoid `propertize' +;; because it reverses the order of the text properties it's given. (defvar erc--message-speaker-statusmsg #("(%p%n%s) %m" 0 1 (font-lock-face erc-default-face) @@ -6108,11 +6228,11 @@ NUH, and the current `erc-response' object.") "Message template for a CTCP ACTION from another user.") (defvar erc--message-speaker-ctcp-action-input - #("* %p%n %m" - 0 2 (font-lock-face #1=(erc-input-face erc-action-face)) - 2 4 (font-lock-face (erc-my-nick-prefix-face . #1#)) - 4 6 (font-lock-face (erc-my-nick-face . #1#)) - 6 9 (font-lock-face #1#)) + (let ((base '(erc-input-face erc-action-face))) ; shared + (concat (propertize "* " 'font-lock-face base) + (propertize "%p" 'font-lock-face `(erc-my-nick-prefix-face ,@base)) + (propertize "%n" 'font-lock-face `(erc-my-nick-face ,@base)) + (propertize " %m" 'font-lock-face base))) "Message template for a CTCP ACTION from current client.") (defvar erc--message-speaker-ctcp-action-statusmsg @@ -6125,12 +6245,12 @@ NUH, and the current `erc-response' object.") "Template for a CTCP ACTION status message from another chan op.") (defvar erc--message-speaker-ctcp-action-statusmsg-input - #("* (%p%n%s) %m" - 0 3 (font-lock-face #1=(erc-input-face erc-action-face)) - 3 5 (font-lock-face (erc-my-nick-prefix-face . #1#)) - 5 7 (font-lock-face (erc-my-nick-face . #1#)) - 7 9 (font-lock-face (erc-notice-face . #1#)) - 9 13 (font-lock-face #1#)) + (let ((base '(erc-input-face erc-action-face))) ; shared + (concat (propertize "* (" 'font-lock-face base) + (propertize "%p" 'font-lock-face `(erc-my-nick-prefix-face ,@base)) + (propertize "%n" 'font-lock-face `(erc-my-nick-face ,@base)) + (propertize "%s" 'font-lock-face `(erc-notice-face ,@base)) + (propertize ") %m" 'font-lock-face base))) "Template for a CTCP ACTION status message from current client.") (defun erc--speakerize-nick (nick &optional disp) @@ -7354,7 +7474,7 @@ complement relevant letters in STRING." t)) ((not fallbackp) (erc-display-message nil '(notice error) (erc-server-buffer) - (format "Unknown channel mode: %S" c))))) + 'channel-mode-unknown ?c (string c))))) (setq erc-channel-modes (sort erc-channel-modes #'string<)) (setq erc--mode-line-mode-string (concat "+" (erc--channel-modes erc--mode-line-chanmodes-arg-len))) @@ -9285,6 +9405,7 @@ SOFTP, only do so when defined as a variable." (incorrect-args . "Incorrect arguments. Usage:\n%c %u\n%d") (cannot-find-file . "Cannot find file %f") (cannot-read-file . "Cannot read file %f") + (channel-mode-unknown . "Unknown channel mode: %c") (connect . "Connecting to %S:%p... ") (country . "%c") (country-unknown . "%d: No such domain") @@ -9299,6 +9420,7 @@ SOFTP, only do so when defined as a variable." . "\n\n*** Connection failed! Re-establishing connection...\n") (disconnected-noreconnect . "\n\n*** Connection failed! Not re-establishing connection.\n") + (ignore-list . "%-8p %s") (reconnecting . "Reconnecting in %ms: attempt %i/%n ...") (reconnect-canceled . "Canceled %u reconnect timer with %cs to go...") (finished . "\n\n*** ERC finished ***\n") diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 7fc6958a00f..89a40151d00 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -317,7 +317,7 @@ The result is a list of three elements: result) ;; We haven't seen a glob yet, so instead append to the start ;; directory. - (setq start-dir (file-name-concat start-dir (car globs)))) + (setq start-dir (concat start-dir (car globs)))) (setq last-saw-recursion nil)) (setq globs (cdr globs))) (list start-dir @@ -341,16 +341,24 @@ Mainly they are not supported because file matching is done with Emacs regular expressions, and these cannot support the above constructs." (let ((globs (eshell-glob-convert glob)) eshell-glob-matches message-shown) - (unwind-protect - (apply #'eshell-glob-entries globs) - (if message-shown - (message nil))) - (or (and eshell-glob-matches (sort eshell-glob-matches #'string<)) - (if eshell-error-if-no-glob - (error "No matches found: %s" glob) - (if eshell-glob-splice-results - (list glob) - glob))))) + (if (null (cadr globs)) + ;; If, after examining GLOB, there are no actual globs, just + ;; bail out. This can happen for remote file names using "~", + ;; like "/ssh:remote:~/file.txt". During parsing, we can't + ;; always be sure if the "~" is a home directory reference or + ;; part of a glob (e.g. if the argument was assembled from + ;; variables). + glob + (unwind-protect + (apply #'eshell-glob-entries globs) + (if message-shown + (message nil))) + (or (and eshell-glob-matches (sort eshell-glob-matches #'string<)) + (if eshell-error-if-no-glob + (error "No matches found: %s" glob) + (if eshell-glob-splice-results + (list glob) + glob)))))) ;; FIXME does this really need to abuse eshell-glob-matches, message-shown? (defun eshell-glob-entries (path globs only-dirs) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 30494bafb48..b220855299e 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -785,9 +785,6 @@ this grossness will be made to disappear by using `call/cc'..." (eshell-errorn (error-message-string err)) (eshell-close-handles 1)))) -(defvar eshell-output-handle) ;Defined in esh-io.el. -(defvar eshell-error-handle) ;Defined in esh-io.el. - (defmacro eshell-with-copied-handles (object &optional steal-p) "Duplicate current I/O handles, so OBJECT works with its own copy. If STEAL-P is non-nil, these new handles will be stolen from the diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index b15f99a0359..5de200ce4b5 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -418,8 +418,10 @@ and the hook `eshell-exit-hook'." (add-hook 'kill-buffer-hook #'eshell-kill-buffer-function t t) - (if eshell-first-time-p - (run-hooks 'eshell-first-time-mode-hook)) + (when eshell-first-time-p + (setq eshell-first-time-p nil) + (run-hooks 'eshell-first-time-mode-hook)) + (run-hooks 'eshell-post-command-hook)) (put 'eshell-mode 'mode-class 'special) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 129134814e3..47645231b75 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -458,8 +458,7 @@ Prepend remote identification of `default-directory', if any." (string-prefix-p "//" filename)) (setq index 2)) (while (< index len) - (when (and (eq (aref filename index) ?/) - (not (get-text-property index 'escaped filename))) + (when (eq (aref filename index) ?/) (push (if (= curr-start index) "/" (substring filename curr-start (1+ index))) parts) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 7d374587dc4..503f64add41 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -250,7 +250,8 @@ information on Eshell, see Info node `(eshell)Top'." (t (get-buffer-create eshell-buffer-name))))) (cl-assert (and buf (buffer-live-p buf))) - (pop-to-buffer buf display-comint-buffer-action) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer buf display-comint-buffer-action)) (unless (derived-mode-p 'eshell-mode) (eshell-mode)) buf)) diff --git a/lisp/files.el b/lisp/files.el index 20d63d33fef..c24e48e3db2 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -862,6 +862,7 @@ GNU and Unix systems). Substitute environment variables into the resulting list of directory names. For an empty path element (i.e., a leading or trailing separator, or two adjacent separators), return nil (meaning `default-directory') as the associated list element." + (declare (type (function (string) list))) (when (stringp search-path) (let ((spath (substitute-env-vars search-path)) (double-slash-special-p @@ -1504,27 +1505,28 @@ containing it, until no links are left at any level. (new (file-name-as-directory (file-truename dirfile counter prev-dirs)))) (setcar prev-dirs (cons (cons old new) (car prev-dirs))) (setq dir new)))) - (if (equal ".." (file-name-nondirectory filename)) - (setq filename - (directory-file-name (file-name-directory (directory-file-name dir))) - done t) - (if (equal "." (file-name-nondirectory filename)) - (setq filename (directory-file-name dir) - done t) - ;; Put it back on the file name. - (setq filename (concat dir (file-name-nondirectory filename))) - ;; Is the file name the name of a link? - (setq target (file-symlink-p filename)) - (if target - ;; Yes => chase that link, then start all over - ;; since the link may point to a directory name that uses links. - ;; We can't safely use expand-file-name here - ;; since target might look like foo/../bar where foo - ;; is itself a link. Instead, we handle . and .. above. - (setq filename (files--splice-dirname-file dir target) - done nil) - ;; No, we are done! - (setq done t)))))))) + (let ((filename-no-dir (file-name-nondirectory filename))) + (if (equal ".." filename-no-dir) + (setq filename + (directory-file-name (file-name-directory (directory-file-name dir))) + done t) + (if (equal "." filename-no-dir) + (setq filename (directory-file-name dir) + done t) + ;; Put it back on the file name. + (setq filename (concat dir filename-no-dir)) + ;; Is the file name the name of a link? + (setq target (file-symlink-p filename)) + (if target + ;; Yes => chase that link, then start all over + ;; since the link may point to a directory name that uses links. + ;; We can't safely use expand-file-name here + ;; since target might look like foo/../bar where foo + ;; is itself a link. Instead, we handle . and .. above. + (setq filename (files--splice-dirname-file dir target) + done nil) + ;; No, we are done! + (setq done t))))))))) filename)) (defun file-chase-links (filename &optional limit) @@ -2113,6 +2115,15 @@ killed." (rename-buffer oname))) (unless (eq (current-buffer) obuf) (with-current-buffer obuf + ;; Restore original buffer's file names so they can be still + ;; used when referencing the now defunct buffer (Bug#68235). + (setq buffer-file-name ofile) + (setq buffer-file-number onum) + (setq buffer-file-truename otrue) + (unless (get-buffer oname) + ;; Restore original's buffer name so 'kill-buffer' can use it + ;; to assign its last name (Bug#68235). + (rename-buffer oname)) ;; We already ran these; don't run them again. (let (kill-buffer-query-functions kill-buffer-hook) (kill-buffer obuf)))))) @@ -8803,9 +8814,10 @@ Otherwise, trash FILENAME using the freedesktop.org conventions, ;; If `system-move-file-to-trash' is defined, use it. (cond ((fboundp 'system-move-file-to-trash) (system-move-file-to-trash filename)) - (trash-directory + ((connection-local-value trash-directory) ;; If `trash-directory' is non-nil, move the file there. - (let* ((trash-dir (expand-file-name trash-directory)) + (let* ((trash-dir (expand-file-name + (connection-local-value trash-directory))) (fn (directory-file-name (expand-file-name filename))) (new-fn (concat (file-name-as-directory trash-dir) (file-name-nondirectory fn)))) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 41581cc7900..fa0c034c816 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -120,7 +120,8 @@ them for `find-ls-option'." :group 'find-dired) (defcustom find-grep-options - (if (or (eq system-type 'berkeley-unix) + (if (or (and (eq system-type 'berkeley-unix) + (not (string-match "openbsd" system-configuration))) (string-match "solaris2" system-configuration)) "-s" "-q") "Option to grep to be as silent as possible. diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 961219eee8f..7af02368d36 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -443,23 +443,9 @@ Returns the list of articles removed." (and (not unread) (not ticked) (not dormant) (memq 'read class)))) (defun gnus-cache-file-name (group article) - (expand-file-name - (if (stringp article) article (int-to-string article)) - (file-name-as-directory - (expand-file-name - (nnheader-translate-file-chars - (if (gnus-use-long-file-name 'not-cache) - group - (let ((group (nnheader-replace-duplicate-chars-in-string - (nnheader-replace-chars-in-string group ?/ ?_) - ?. ?_))) - ;; Translate the first colon into a slash. - (when (string-match ":" group) - (setq group (concat (substring group 0 (match-beginning 0)) - "/" (substring group (match-end 0))))) - (nnheader-replace-chars-in-string group ?. ?/))) - t) - gnus-cache-directory)))) + (nnmail-group-pathname + group gnus-cache-directory + (if (stringp article) article (int-to-string article)))) (defun gnus-cache-update-article (group article) "If ARTICLE is in the cache, remove it and re-enter it." @@ -699,9 +685,10 @@ If LOW, update the lower bound instead." (file-name-as-directory (expand-file-name gnus-cache-directory)))) (directory-file-name directory)) - (nnheader-replace-chars-in-string - (substring (directory-file-name directory) (match-end 0)) - ?/ ?.))) + (url-unhex-string + (nnheader-replace-chars-in-string + (substring (directory-file-name directory) (match-end 0)) + ?/ ?.)))) nums alphs) (when top (gnus-message 5 "Generating the cache active file...") diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index a967d6d71da..9cff2e2f109 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -1002,10 +1002,11 @@ Responsible for handling and, or, and parenthetical expressions.") (defsubst gnus-search-single-p (query) "Return t if QUERY is a search for a single message." - (let ((q (alist-get 'parsed-query query))) - (and (= (length q ) 1) - (consp (car-safe q)) - (eq (caar q) 'id)))) + (unless (alist-get 'thread query) + (let ((q (alist-get 'parsed-query query))) + (and (= (length q ) 1) + (consp (car-safe q)) + (eq (caar q) 'id))))) (cl-defmethod gnus-search-transform ((engine gnus-search-engine) (query list)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index dc66e1375ab..d4895f3c5f8 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -8939,7 +8939,8 @@ The difference between N and the number of articles fetched is returned." (while (and (> n 0) (not error)) (setq header (gnus-summary-article-header)) - (if (and (eq (mail-header-number header) + (if (and (null gnus-alter-header-function) + (eq (mail-header-number header) (cdr gnus-article-current)) (equal gnus-newsgroup-name (car gnus-article-current))) @@ -8947,7 +8948,8 @@ The difference between N and the number of articles fetched is returned." ;; displayed article, then we take a look at the actual ;; References header, since this is slightly more ;; reliable than the References field we got from the - ;; server. + ;; server. But if we altered the header, we should prefer + ;; the version from the header vector. (with-current-buffer gnus-original-article-buffer (nnheader-narrow-to-headers) (unless (setq ref (message-fetch-field "references")) @@ -8955,8 +8957,8 @@ The difference between N and the number of articles fetched is returned." (setq ref (gnus-extract-message-id-from-in-reply-to ref)))) (widen)) (setq ref - ;; It's not the current article, so we take a bet on - ;; the value we got from the server. + ;; It's not the current article, or we altered the header, + ;; so we use whats in the header vector. (mail-header-references header))) (if (and ref (not (equal ref ""))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index dab66b60205..f1fc129a505 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1360,6 +1360,7 @@ slower." ("nnimap" post-mail address prompt-address physical-address respool server-marks cloud) ("nnmaildir" mail respool address server-marks) + ("nnatom" none address) ("nnnil" none)) "An alist of valid select methods. The first element of each list lists should be a string with the name diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 979d2fecf56..b2805774162 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -5768,8 +5768,10 @@ The result is a fixnum." (with-temp-buffer (insert-buffer-substring buf) (message-clone-locals buf) - ;; Avoid re-doing things like GPG-encoding secret parts. - (if (not encoded-cache) + ;; Avoid re-doing things like GPG-encoding secret parts, unless + ;; the user has requested that attachments be externalized, in + ;; which case we have to re-encode the message body. + (if (or mml-externalize-attachments (not encoded-cache)) (message-encode-message-body) (erase-buffer) (insert encoded-cache)) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 109b6c17c2c..223da19a164 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -105,7 +105,7 @@ This is only used if `mm-inline-large-images' is set to (lambda () (let ((inhibit-read-only t)) (remove-images b b) - (delete-region b (1+ b))))))) + (delete-region b (+ b 2))))))) (defvar mm-w3m-setup nil "Whether gnus-article-mode has been setup to use emacs-w3m.") diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el new file mode 100644 index 00000000000..add9ae2dff9 --- /dev/null +++ b/lisp/gnus/nnatom.el @@ -0,0 +1,276 @@ +;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Author: Daniel Semyonov <daniel@dsemy.com> + +;; This file is part of GNU Emacs. + +;; nnatom 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. + +;; nnatom 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 nnatom. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Gnus backend for HTTP or local feeds following the +;; Atom Syndication Format <https://www.ietf.org/rfc/rfc4287>. + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) + +(require 'nnfeed) +(require 'mm-url) +(require 'dom) + +(defgroup nnatom nil + "Atom backend for Gnus." + :group 'nnfeed) + +(nnoo-declare nnatom nnfeed) + +(nnfeed-define-basic-backend-interface nnatom) + +;;;; Atom feed parser: + +(defun nnatom--read-feed (feed _) + "Return a list structure representing FEED, or nil." + (if (string-match-p "\\`https?://" feed) + (nnheader-report + nnatom-backend + "Address shouldn't start with \"http://\" or \"https://\"") + (with-temp-buffer + (condition-case e + (if (file-name-absolute-p feed) + (insert-file-contents feed) + (mm-url-insert-file-contents (concat "https://" feed))) + (file-error (nnheader-report nnatom-backend (cdr e))) + (:success (when-let ((data (if (libxml-available-p) + (libxml-parse-xml-region + (point-min) (point-max)) + (car (xml-parse-region + (point-min) (point-max))))) + (authors (list 'authors))) + (when (eq (car data) 'top) + (setq data (assq 'feed data))) + (dom-add-child-before data authors) + (let ((all (dom-children data))) + (while-let ((rest (cdr all)) + (child (car-safe rest)) + (type (car-safe child)) + ((not (eq type 'entry)))) + (and (or (eq type 'author) + (eq type 'contributor)) + (dom-add-child-before authors child)) + (setq all rest)) + ;; Order of entries is reversed as most Atom feeds + ;; list only the "most recent" entries, in reverse + ;; chronological order. + (setcdr all (nreverse (cdr all)))) + data)))))) +(defvoo nnatom-read-feed-function #'nnatom--read-feed + nil nnfeed-read-feed-function) + +(defun nnatom--read-group (data) + "Return the next group and the remaining DATA in a cons cell, or nil." + `(,data)) +(defvoo nnatom-read-group-function #'nnatom--read-group + nil nnfeed-read-group-function) + +(defun nnatom--read-article (data _) + "Return the next article and the remaining DATA in a cons cell, or nil." + (when (eq (car data) 'feed) (setq data (dom-children data))) + ;; Discard any children between/after entries. + (while (and data (not (eq (car-safe (car data)) 'entry))) (pop data)) + (when-let ((article (car data)) + (auths (list 'authors)) (links (list 'links))) + (dom-add-child-before article links) + (dom-add-child-before article auths) + (dolist (child (cddddr article) `(,article . ,(cdr data))) + (pcase (car-safe child) ; Authors and links can appear + ((or 'author 'contributor) ; anywhere in the entry so we + (dom-add-child-before auths child) ; collect them all here to + (dom-add-child-before links child)) ; avoid looping over the + ((or 'link ; entry multiple times later. + (and 'content (guard (assq 'src (dom-attributes child))))) + (dom-add-child-before links child)))))) +(defvoo nnatom-read-article-function #'nnatom--read-article + nil nnfeed-read-article-function) + +(defun nnatom--read-title (group) + "Return the title of GROUP, or nil." + (dom-text (dom-child-by-tag group 'title))) +(defvoo nnatom-read-title-function #'nnatom--read-title + nil nnfeed-read-title-function) + +(defun nnatom--read-description (group) + "Return the description of GROUP, or nil." + (dom-text (dom-child-by-tag group 'subtitle))) +(defvoo nnatom-read-description-function #'nnatom--read-description + nil nnfeed-read-description-function) + +(defun nnatom--read-article-or-group-authors (article-or-group) + "Return the authors of ARTICLE-OR-GROUP, or nil." + (when-let + ((a (mapconcat + (lambda (author) + (let* ((name (dom-text (dom-child-by-tag author 'name))) + (name (unless (string-blank-p name) name)) + (email (dom-text (dom-child-by-tag author 'email))) + (email (unless (string-blank-p email) email))) + (or (and name email (format "%s <%s>" name email)) name email))) + (dom-children (dom-child-by-tag article-or-group 'authors)) + ", ")) + ((not (string-blank-p a)))) + a)) +(defvoo nnatom-read-author-function #'nnatom--read-article-or-group-authors + nil nnfeed-read-author-function) +(defvoo nnatom-read-group-author-function + #'nnatom--read-article-or-group-authors + nil nnfeed-read-group-author-function) + +(defun nnatom--read-subject (article) + "Return the subject of ARTICLE, or nil." + (dom-text (dom-child-by-tag article 'title))) +(defvoo nnatom-read-subject-function #'nnatom--read-subject + nil nnfeed-read-subject-function) + +(defun nnatom--read-id (article) + "Return the ID of ARTICLE. +If the ARTICLE doesn't contain an ID but it does contain a subject, +return the subject. Otherwise, return nil." + (or (dom-text (dom-child-by-tag article 'id)) + (nnatom--read-subject article))) +(defvoo nnatom-read-id-function #'nnatom--read-id + nil nnfeed-read-id-function) + +(defun nnatom--read-publish (article) + "Return the date and time ARTICLE was published, or nil." + (when-let (d (dom-child-by-tag article 'published)) + (date-to-time (dom-text d)))) +(defvoo nnatom-read-publish-date-function #'nnatom--read-publish + nil nnfeed-read-publish-date-function) + +(defun nnatom--read-update (article) + "Return the date and time of the last update to ARTICLE, or nil." + (when-let (d (dom-child-by-tag article 'updated)) + (date-to-time (dom-text d)))) +(defvoo nnatom-read-update-date-function #'nnatom--read-update + nil nnfeed-read-update-date-function) + +(defun nnatom--read-links (article) + "Return all links contained in ARTICLE, or nil." + (let ((alt 0) (rel 0) (sel 0) (enc 0) (via 0) (aut 0)) + (mapcan + (lambda (link) + (when-let ((l (car-safe link))) + (or + (when-let (((eq l 'content)) + (src (dom-attr link 'src)) + (label (concat "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt))))) + `(((("text/plain") . ,(format "%s: %s\n" label src)) + (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " + src label))))) + (when-let (((or (eq l 'author) (eq l 'contributor))) + (name (dom-text (dom-child-by-tag link 'name))) + (name (if (string-blank-p name) + (concat "Author" + (and (< 1 (cl-incf aut)) + (format " %s" aut))) + name)) + (uri (dom-text (dom-child-by-tag link 'uri))) + ((not (string-blank-p uri)))) + `(((("text/plain") . ,(format "%s: %s\n" name uri)) + (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " + uri name))))) + (when-let (((eq l 'link)) + (attrs (dom-attributes link)) + (label (or (cdr (assq 'title attrs)) + (pcase (cdr (assq 'rel attrs)) + ("related" + (concat "Related" + (and (< 1 (cl-incf rel)) + (format " %s" rel)))) + ("self" + (concat "More" + (and (< 1 (cl-incf sel)) + (format " %s" sel)))) + ("enclosure" + (concat "Enclosure" + (and (< 1 (cl-incf enc)) + (format " %s" enc)))) + ("via" + (concat "Source" + (and (< 1 (cl-incf via)) + (format " %s" via)))) + (_ (if-let + ((lang (cdr (assq 'hreflang link)))) + (format "Link (%s)" lang) + (concat + "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt)))))))) + (link (cdr (assq 'href attrs)))) + `(((("text/plain") . ,(format "%s: %s\n" label link)) + (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " + link label)))))))) + (dom-children (dom-child-by-tag article 'links))))) +(defvoo nnatom-read-links-function #'nnatom--read-links + nil nnfeed-read-links-function) + +(defun nnatom--read-part (part type) + (let* ((atypes '("html" "plain")) + (mtypes '(("xhtml" . "text/html") ("text" . "text/plain"))) + (xsuff (concat "[+/]xml\\(-\\(dtd\\|external-parsed-entity\\)\\)?\\'" + "\\|^text")) + (part (if (string= type "xhtml") + (with-temp-buffer + (dom-print (dom-child-by-tag part 'div) nil t) + (buffer-substring-no-properties + (point-min) (point-max))) + (dom-text part))) + (type (if (member type atypes) (concat "text/" type) type)) + (type (or (cdr (assoc type mtypes)) type))) + (unless (string-blank-p part) + `(,part (Content-Type . ,(or type (setq type "text/plain"))) + ,(and (not (string-match-p xsuff type)) + '(Content-Transfer-Encoding . "base64")))))) + +(defun nnatom--read-parts (article) + "Return all parts contained in ARTICLE, or an empty HTML part with links." + (let* ((summary (dom-child-by-tag article 'summary)) + (stype (cdr (assq 'type (dom-attributes summary)))) + (summary (nnatom--read-part summary stype)) + (content (dom-child-by-tag article 'content)) + (ctype (cdr (assq 'type (dom-attributes content)))) + (content (nnatom--read-part content ctype)) + (st (string= stype ctype)) + parts) + (cond ((and summary content) + (and st (push summary parts)) + (push (append content '(links)) parts) + (or st (push summary parts))) + ((setq content (or summary content)) + (push (append content '(links)) parts)) + (t (push '((nil (Content-Type . "text/html") links)) parts))) + parts)) +(defvoo nnatom-read-parts-function #'nnatom--read-parts + nil nnfeed-read-parts-function) + +(gnus-declare-backend (symbol-name nnatom-backend) 'none 'address) + +(provide 'nnatom) + +;;; nnatom.el ends here diff --git a/lisp/gnus/nnfeed.el b/lisp/gnus/nnfeed.el new file mode 100644 index 00000000000..d6963b2e929 --- /dev/null +++ b/lisp/gnus/nnfeed.el @@ -0,0 +1,683 @@ +;;; nnfeed.el --- Generic feed backend for Gnus -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Author: Daniel Semyonov <daniel@dsemy.com> + +;; This file is part of GNU Emacs. + +;; nnfeed 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. + +;; nnfeed 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 nnfeed. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Generic Gnus backend (intended) for implementing backends for web +;; feeds (Atom, RSS). +;; +;; This backend is abstract - it doesn't implement a parser for any +;; specific web feed type, and so can't be used independently. +;; +;; Instead, it implements a generic parser, feed data storage and most +;; of the Gnus backend interface; the intended use for this backend is +;; to be a source of inheritance for backends supporting new web feed +;; types. +;; +;; To implement new backends, use `nnfeed-define-basic-backend-interface': +;; +;; ... +;; (require 'nnfeed) +;; +;; (nnoo-declare nnfoo nnfeed) +;; +;; (nnfeed-define-basic-backend-interface nnfoo) +;; ... +;; [ definitions of parsing functions, see the "Feed parser interface" +;; section for more information. ] +;; +;; (defvoo nnfoo-read-feed-function #'nnfoo--read-feed +;; nil nnfeed-read-feed-function) +;; ... +;; (gnus-declare-backend (symbol-name nnfeed-backend) 'none 'address) +;; +;; (provide 'nnfoo) +;; +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'gnus) +(require 'nnoo) + +(defgroup nnfeed nil + "Generic feed backend for Gnus." + :group 'gnus) + +(defcustom nnfeed-date-format "%F %X%p" + "Format of displayed dates (see function `format-time-string')." + :type 'string) + +(nnoo-declare nnfeed) + +(defvoo nnfeed-backend nil + "Symbol which identifies this backend.") + +(defvoo nnfeed-status-string nil + "Last status message reported by this backend.") + +;; This macro should be used to define inheriting backends. + +(defmacro nnfeed-define-basic-backend-interface (backend) + "Define a basic set of functions and variables for BACKEND." + `(progn + (defvoo ,(nnoo-symbol backend 'backend) ',backend nil nnfeed-backend) + (defvoo ,(nnoo-symbol backend 'status-string) + nil nil nnfeed-status-string) + (defvoo ,(nnoo-symbol backend 'group) nil nil nnfeed-group) + (defvoo ,(nnoo-symbol backend 'servers) + (make-hash-table :test 'equal) nil nnfeed-servers) + (defvoo ,(nnoo-symbol backend 'group-article-ids) + (make-hash-table :test 'equal) nil nnfeed-group-article-ids) + (defvoo ,(nnoo-symbol backend 'group-articles) + (make-hash-table :test 'eql) nil nnfeed-group-articles) + (defvoo ,(nnoo-symbol backend 'group-article-max-num) 0 nil + nnfeed-group-article-max-num) + (defvoo ,(nnoo-symbol backend 'group-article-mix-num) 1 nil + nnfeed-group-article-min-num) + ,@(mapcar (lambda (fun) + `(deffoo ,(nnoo-symbol backend fun) (&optional server) + (,(nnoo-symbol 'nnoo fun) ',backend server))) + '(server-opened status-message)) + (deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs) + (nnfeed-open-server server defs ',backend)) + (nnoo-import ,backend (nnfeed)))) + +;;;; Feed parser interface: + +;; The following set of server variables define a parser for a +;; specific web feed type. +;; An inheriting backend doesn't necessarily have to define all of +;; these functions (see the comments below for more information). +;; Apart from this set of variables there is also +;; `nnfeed-print-content-function' which can optionally be defined +;; by an inheriting backend to allow more advanced control over the +;; printing of articles. + +(defvoo nnfeed-read-feed-function #'ignore + "Function returning a Lisp object representing a feed (or part of it). + +It should accept two arguments, the address of a feed and the name of +a group (or nil). +If a group name is supplied, it should return a representation of only +the group (as if it was extracted from the feed with +`nnfeed-read-group-function').") + +(defvoo nnfeed-read-group-function #'ignore + "Function returning a cons cell of a group and remaining data from a feed. + +The returned group can be represented by any Lisp object. +It should accept a single argument, a Lisp object representing a feed +\(as can be returned by this function or `nnfeed-read-feed-function').") + +(defvoo nnfeed-read-article-function #'ignore + "Function returning a cons cell of an article and remaining data from a group. + +The returned article can be represented by any Lisp object. +It should accept two arguments, a Lisp object representing a group +\(as can be returned by this function or `nnfeed-read-group-function'), +and a flag indicating whether the last article was not new or updated.") + +(defvoo nnfeed-read-title-function #'ignore + "Function returning the title of a group (a string). + +It should accept a single argument, a Lisp object representing a group +\(as returned by `nnfeed-read-group-function').") + +;; Optional. +(defvoo nnfeed-read-description-function #'ignore + "Function returning the description of a group (a string), or nil. + +It should accept a single argument, a Lisp object representing a group +\(as returned by `nnfeed-read-group-function').") + +;; Either this function or `nnfeed-read-author-function' is required. +(defvoo nnfeed-read-group-author-function #'ignore + "Function returning the author of a group (a string), or nil. + +It should accept a single argument, a Lisp object representing a group +\(as returned by `nnfeed-read-group-function')..") + +(defvoo nnfeed-read-id-function #'ignore + "Function returning the ID of an article. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +(defvoo nnfeed-read-subject-function #'ignore + "Function returning the subject of an article (a string), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; Either this function or `nnfeed-read-update-date-function' is required. +(defvoo nnfeed-read-publish-date-function #'ignore + "Function returning the publish date of an article (a time value), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; Either this function or `nnfeed-read-publish-date-function' is required. +(defvoo nnfeed-read-update-date-function #'ignore + "Function returning the update date of an article (a time value), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; Either this function or `nnfeed-read-group-author-function' is required. +(defvoo nnfeed-read-author-function #'ignore + "Function returning the author of an article (a string), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +(defvoo nnfeed-read-headers-function #'ignore + "Function returning an alist of article-wide MIME headers. + +Each element of this alist maps a MIME header (a symbol, +i.e. `Content-Type') to its value. As a special case, `:boundary' +maps to a string which will serve as the boundary between article +parts. This must be supplied if a custom boundary is used in a +multipart content type header. The default boundary is \"-_nnfeed_-\", +and is automatically modified to match the name of the back end. +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; As mentioned in their docstrings, the last two parsing functions +;; can optionally return any Lisp representation they want, provided +;; an appropriate `nnfeed-print-content-function' is defined. This +;; means they are also not _strictly_ required. + +(defvoo nnfeed-read-links-function #'ignore + "Function returning all links contained in an article. + +With the default `nnfeed-print-content-function', it should return a +list of links, where each link is an alist mapping MIME content types +to links formatted for display in a part of that type. Each content +type may also be a list of content types. +Otherwise, it could return any Lisp object. +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +(defvoo nnfeed-read-parts-function #'ignore + "Function returning an alist associating parts of an article to their headers. + +With the default `nnfeed-print-content-function', each part should be a +string. Otherwise, it can be any Lisp object. The \"headers\" of +each part should be a list where each element is either a cons of a +MIME header (a symbol, i.e. `Content-Type') and its value (a string), +or any other Lisp object. MIME headers will be printed, the rest will +be passed on to `nnfeed-print-content-function', which recognizes the +following extra data by default: +- `links', if present, will cause links to be printed in the part. +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;;;; Feed data storage: + +;; This section defines the data types used to store feed data, and +;; functions to read and write it. +;; All variables in this section are automatically defined by +;; `nnfeed-define-basic-backend-interface'. + +(defvoo nnfeed-servers (make-hash-table :test 'equal) + "Hash table mapping known servers to their groups. + +Each value in this table should itself be a hash table mapping known +group names to their data, which should be a vector of the form +[GROUP IDS ARTICLES MAX MIN DESCRIPTION], where: +- GROUP is the \"real\" group name (the name known to the server). +- IDS is a hash table mapping article IDs to their numbers. +- ARTICLES is a hash table mapping article numbers to articles and + their attributes (see `nnfeed-group-articles'). +- MAX is the maximum article number. +- MIN is the minimum article number. +- DESCRIPTION is the group description.") + +(defvoo nnfeed-group-names (make-hash-table :test 'equal) + "Hash table mapping real group names to their custom name.") + +(defun nnfeed--server-address (server) + "Return SERVER's real address." + (if (string-suffix-p "-ephemeral" server) + (setq server (or (cadr (assq (nnoo-symbol nnfeed-backend 'address) + (cddr (gnus-server-to-method + (concat + (symbol-name nnfeed-backend) ":" + server))))) + server)) + server)) + +(defun nnfeed--server-file (server) + "Return the file containing data for SERVER." + (expand-file-name (format "%s/%s.eld" + (string-trim (symbol-name nnfeed-backend) + "nn") + (gnus-newsgroup-savable-name + (nnfeed--server-address server))) + gnus-directory)) + +(defun nnfeed--read-server (server) + "Read SERVER's information from storage." + (if-let ((f (nnfeed--server-file server)) + ((file-readable-p f))) + (with-temp-buffer + (insert-file-contents f) + (goto-char (point-min)) + (puthash server (read (current-buffer)) nnfeed-servers)) + (nnheader-report nnfeed-backend "Can't read %s" server))) + +(defun nnfeed--write-server (server) + "Write SERVER's information to storage." + (if-let ((f (nnfeed--server-file server)) + ((file-writable-p f))) + (if-let ((s (gethash server nnfeed-servers)) + ((hash-table-p s))) + (with-temp-file f + (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n") + (prin1 s (current-buffer)) + (insert "\n") + t) + t) + (nnheader-report nnfeed-backend "Can't write %s" f))) + +;; The following function uses the parsing functions defined in the last +;; section to parse a feed (or just one group from it). +;; This is the only place where these parsing functions are used; the Gnus +;; backend interface extracts all required information from the parsed feed. + +(defun nnfeed--parse-feed (feed &optional group) + "Parse GROUP from FEED into a new or existing server. +If GROUP is omitted or nil, parse the entire FEED." + (let* ((feed (nnfeed--server-address feed)) + (s (or (gethash feed nnfeed-servers) (nnfeed--read-server feed) + (make-hash-table :test 'equal))) + (name group) ; (Maybe) fake name (or nil) + (group (aref (gethash group s `[,group]) 0)) ; Real name (or nil) + data) + (when (setq data (funcall nnfeed-read-feed-function feed group)) + (while-let ((cg (or (and name (cons data)) ; `data' is a single group + (funcall nnfeed-read-group-function data))) + (cg (prog1 (car cg) (setq data (cdr cg))))) + (let* ((name (funcall nnfeed-read-title-function cg)) ; Real name + (group (gethash name nnfeed-group-names name)) ; (Maybe) fake name + (info (gnus-get-info + (concat (symbol-name nnfeed-backend) "+" feed ":" group))) + (g (or (gethash group s) + `[ ,name ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1 ""])) + (desc (funcall nnfeed-read-description-function cg)) + (ids (aref g 1)) + (articles (aref g 2)) + (max (aref g 3)) + (max (if max max + (setq max 0) ; Find max article number + (dolist ; remembered by Gnus. + ( r (cons (gnus-info-read info) + (gnus-info-marks info)) + max) + (mapc (lambda (x) + (let ((x (if (consp x) + (if (< (car x) (cdr x)) + (cdr x) (car x)) + x))) + (when (< max x) (setq max x)))) + (if (symbolp (car r)) (cdr r) r))))) + (group-author (funcall nnfeed-read-group-author-function cg)) + stale) + (and desc (aset g 5 desc)) + (while-let ((article (funcall nnfeed-read-article-function cg stale)) + (article (prog1 (car article) (setq cg (cdr article))))) + (when-let ((id (funcall nnfeed-read-id-function article)) + (id (format "<%s@%s.%s>" id name nnfeed-backend))) + (let* ((num (gethash id ids)) + (update (funcall nnfeed-read-update-date-function article)) + (prev-update (aref (gethash num articles + '[nil nil nil nil nil]) + 4))) + (if (or (null num) ; New article ID. + (and (null prev-update) update) + (and prev-update update + (time-less-p prev-update update))) + (let* ((num (or num (aset g 3 (setq max (1+ max))))) + (publish (funcall nnfeed-read-publish-date-function + article))) + (setf + (gethash id (aref g 1)) num + (gethash num (aref g 2)) + `[ ,id + ,(or (funcall nnfeed-read-author-function article) + group-author group) + ,(or (funcall nnfeed-read-subject-function article) + "no subject") + ,(or publish update '(0 0)) ; published + ,(or update publish '(0 0)) ; updated + ,(funcall nnfeed-read-links-function article) + ,(funcall nnfeed-read-parts-function article) + ,(funcall nnfeed-read-headers-function article)] + stale nil)) + (setq stale t))))) + (puthash group g s))) + (puthash feed s nnfeed-servers)))) + +;;;; Gnus backend functions: + +;; The following two sections define a Gnus backend interface based on +;; the parsed data from the last section. +;; All server variables in this section are automatically defined by +;; `nnfeed-define-basic-backend-interface'. +;; For more information about these functions see the "Back End +;; Interface" section of the Gnus manual. + +(defvoo nnfeed-group nil + "Name of the current group.") + +(defvoo nnfeed-group-article-ids (make-hash-table :test 'equal) + "Hash table mapping article IDs to their article number.") + +(defvoo nnfeed-group-articles (make-hash-table :test 'eql) + "Hash table mapping article numbers to articles and their attributes. + +Each value in this table should be a vector of the form +[ID FROM SUBJECT DATE UPDATED LINKS PARTS HEADERS], where: +- ID is the ID of the article. +- FROM is the author of the article or group. +- SUBJECT is the subject of the article. +- DATE is the date the article was published, or last updated (time value). +- UPDATE is the date the article was last updated, or published (time value). +- LINKS is a collection of links (any Lisp object). +- PARTS is an alist associating the content of each part of the + article to its headers. +- HEADERS is an alist associating article-wide MIME headers to their value.") + +(defvoo nnfeed-group-article-max-num 0 + "Maximum article number for the current group.") + +(defvoo nnfeed-group-article-min-num 1 + "Minimum article number for the current group.") + +(nnoo-define-basics nnfeed) + +(defun nnfeed--current-server-no-prefix () + "Remove the \"<backend>+\" prefix from the current server." + (string-remove-prefix (concat (symbol-name nnfeed-backend) "+") + (nnoo-current-server nnfeed-backend))) + +(defun nnfeed--group-data (group server) + "Get parsed data for GROUP from SERVER." + (when-let ((server (nnfeed--server-address server)) + (s (gethash server nnfeed-servers)) + ((hash-table-p s))) + (gethash group s))) + +(defun nnfeed-retrieve-article (article group) + "Retrieve headers for ARTICLE from GROUP." + (if-let ((a (gethash article (aref group 2)))) + (insert (format "221 %s Article retrieved. +From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" + article + (aref a 1) + (aref a 2) + (format-time-string "%F %H:%M" (aref a 3)) + (aref a 0))) + (insert "404 Article not found.\n.\n"))) + +(deffoo nnfeed-retrieve-headers (articles &optional group server _fetch-old) + (if-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + `[ nil ,nnfeed-group-article-ids ,nnfeed-group-articles + nil nil nil]))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (or (and (stringp (car articles)) + (mapc (lambda (a) + (nnfeed-retrieve-article + (gethash a (aref g 2)) g)) + articles)) + (and (numberp (car articles)) + (range-map (lambda (a) (nnfeed-retrieve-article a g)) + articles))) + 'headers) + (nnheader-report nnfeed-backend "Group %s not found" (or group "")))) + +(deffoo nnfeed-open-server (server &optional defs backend) + (let ((backend (or backend 'nnfeed)) + (a (nnfeed--server-address server)) + s) + (nnoo-change-server backend server defs) + (when (setq s (or (gethash a nnfeed-servers) (nnfeed--read-server server))) + (maphash (lambda (group g) + (setq g (aref g 0)) + (unless (string= group g) + (puthash g group nnfeed-group-names))) + s)) + (setq a (nnfeed--server-file server)) + (or s (condition-case _ (make-directory (file-name-parent-directory a) t) + (:success (file-writable-p a)) + (t nil)) + (and (nnoo-close-server nnfeed-backend server) + (nnheader-report + nnfeed-backend "Server file %s not readable or writable" + server))))) + +(deffoo nnfeed-request-close () + (when (hash-table-p nnfeed-servers) + (maphash (lambda (server _) (nnfeed--write-server server)) nnfeed-servers) + (setq nnfeed-servers (make-hash-table :test 'equal))) + (setq nnfeed-status-string nil) + t) + +;; The default content printing function, which should be suitable for +;; most inheriting backends. + +(defun nnfeed--print-content (content attributes links) + "Return CONTENT formatted according to ATTRIBUTES, with LINKS possibly added." + (let ((links (and (memq 'links attributes) links))) + (when (or content links) + (concat + (and content (format "%s\n\n" content)) + (mapconcat (lambda (link) + (cdr (assoc (cdr (assq 'Content-Type attributes)) link + (lambda (types type) + (if (stringp types) (string= types type) + (member type types)))))) + links))))) + +(defvoo nnfeed-print-content-function #'nnfeed--print-content + "Function returning a single piece of content for an article (a string). + +It should accept three arguments, a part and its attributes (as returned +by `nnfeed-read-parts-function'), and links (as returned by +`nnfeed-read-links-function').") + +(defun nnfeed--print-part (content headers mime links) + "Print part of an article using its CONTENT, HEADERS, and LINKS. +Only HEADERS of a type included in MIME are considered." + (concat + (mapconcat (lambda (header) + (when-let ((m (car-safe header)) + ((member m mime))) + (format "%s: %s\n" m (cdr header)))) + headers) + "\n" + (funcall nnfeed-print-content-function content headers links))) + +(deffoo nnfeed-request-article (article &optional group server to-buffer) + (if-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + (and (setq group nnfeed-group) + `[ nil ,nnfeed-group-article-ids + ,nnfeed-group-articles + ,nnfeed-group-article-max-num + ,nnfeed-group-article-min-num nil]))) + (num (or (and (stringp article) + (gethash article (aref g 1))) + (and (numberp article) article))) + ((and (<= num (aref g 3)) + (>= num (aref g 4)))) + (a (gethash num (aref g 2)))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (let* ((links (aref a 5)) + (parts (aref a 6)) + (headers (aref a 7)) + (boundary (or (cdr (assq :boundary headers)) + (format "-_%s_-" nnfeed-backend))) + (multi (length> parts 1)) + (mime '( Content-Type Content-Disposition + Content-Transfer-Encoding))) + (insert (format + "Subject: %s\nFrom: %s\nDate: %s\nMessage-ID: %s\n" + (aref a 2) (aref a 1) + (format-time-string + nnfeed-date-format (or (aref a 3) '(0 0))) + (aref a 0)) + (if (assq 'MIME-Version headers) "" "MIME-Version: 1.0\n") + (mapconcat (lambda (header) + (unless (keywordp (car header)) + (format "%s: %s\n" (car header) (cdr header)))) + headers) + (if multi + (if (assq 'Content-Type headers) "" + (format + "Content-Type: multipart/alternative; boundary=%s\n" + boundary)) + (prog1 (nnfeed--print-part + (caar parts) (cdar parts) mime links) + (setq parts nil))) + (mapconcat (lambda (part) + (format "--%s\n%s\n" boundary + (nnfeed--print-part + (car part) (cdr part) mime links))) + parts) + (if multi (format "--%s--" boundary) "\n"))) + `(,group . ,num)) + (nnheader-report nnfeed-backend "No such article"))) + +(deffoo nnfeed-request-group (group &optional server fast _info) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (if-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (if fast (nnfeed--group-data group server) + (setq server (nnfeed--parse-feed server group)) + (and (hash-table-p server) (gethash group server))) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) 0 1 ""]))) + (progn + (setq nnfeed-group group + nnfeed-group-article-ids (aref g 1) + nnfeed-group-articles (aref g 2) + nnfeed-group-article-max-num (aref g 3) + nnfeed-group-article-min-num (aref g 4)) + (insert (format "211 %s %s %s \"%s\"" + (hash-table-count nnfeed-group-article-ids) + nnfeed-group-article-min-num + nnfeed-group-article-max-num group)) + t) + (insert "404 group not found") + (nnheader-report nnfeed-backend "Group %s not found" group)))) + +(deffoo nnfeed-close-group (group &optional server) + (and (string= group nnfeed-group) + (setq nnfeed-group nil + nnfeed-group-article-ids (make-hash-table :test 'equal) + nnfeed-group-articles (make-hash-table :test 'eql) + nnfeed-group-article-max-num 0 + nnfeed-group-article-min-num 1)) + (setq server (or server (nnfeed--current-server-no-prefix))) + (nnfeed--write-server server)) + +(deffoo nnfeed-request-list (&optional server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (when-let ((p (point)) + (s (nnfeed--parse-feed + (or server (nnfeed--current-server-no-prefix)))) + ((hash-table-p s))) + (maphash (lambda (group g) + (insert (format "\"%s\" %s %s y\n" + group (aref g 3) (aref g 4)))) + s) + (not (= (point) p))))) + +(deffoo nnfeed-request-post (&optional _server) + (nnheader-report nnfeed-backend "%s is a read only backend" nnfeed-backend)) + +;;;; Optional back end functions: + +(deffoo nnfeed-retrieve-groups (_groups &optional server) + (nnfeed-request-list server) + 'active) + +(deffoo nnfeed-request-type (_group &optional _article) + 'unknown) + +(deffoo nnfeed-request-group-description (group &optional server) + (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (nnfeed--group-data group server))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert group " " (aref g 5) "\n")))) + +(deffoo nnfeed-request-list-newsgroups (&optional server) + (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (s (gethash (nnfeed--server-address server) nnfeed-servers)) + ((hash-table-p s))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (maphash (lambda (group g) + (insert group " " (aref g 5) "\n")) + s)))) + +(deffoo nnfeed-request-rename-group (group new-name &optional server) + (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (a (nnfeed--server-address server)) + (s (or (gethash a nnfeed-servers) + (and ; Open the server to add it to `nnfeed-servers' + (save-match-data + (nnfeed-open-server + server + (cdr ; Get defs and backend. + (assoc a (cdr (assq nnfeed-backend nnoo-state-alist)) + (lambda (car key) + (and (stringp car) + (string-match + (concat + "\\`\\(\\(nn[[:alpha:]]+\\)\\+\\)?" + (regexp-quote key) "\\'") + car) + (setq server car))))) + (if (match-string 1 server) + (intern (match-string 2 server)) 'nnfeed))) + (gethash a nnfeed-servers)))) + (g (or (nnfeed--group-data group a) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1 ""]))) + (puthash new-name g s) + (puthash group new-name nnfeed-group-names) + (remhash group s) + (and (string= group nnfeed-group) + (setq nnfeed-group new-name)) + t)) + +(provide 'nnfeed) + +;;; nnfeed.el ends here diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 17a55f988c9..c61dfecfa7a 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -97,7 +97,7 @@ Uses the same syntax as `nnmail-split-methods'.") (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. Possible choices are nil (use default methods), `anonymous', -`login', `plain' and `cram-md5'.") +`login', `plain', `cram-md5' and `xoauth2'.") (defvoo nnimap-expunge 'on-exit "When to expunge deleted messages. diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index fef12eebe09..a9f5b89c6fe 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -33,6 +33,7 @@ (require 'mail-source) (require 'mm-util) (require 'gnus-int) +(require 'browse-url) (autoload 'mail-send-and-exit "sendmail" nil t) @@ -627,7 +628,7 @@ These will be logged to the \"*nnmail split*\" buffer." (concat (let ((dir (file-name-as-directory (expand-file-name dir)))) (setq group (nnheader-replace-duplicate-chars-in-string - (nnheader-replace-chars-in-string group ?/ ?_) + (browse-url-url-encode-chars group "[/%]") ?. ?_)) (setq group (nnheader-translate-file-chars group)) ;; If this directory exists, we use it directly. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index a291893e9a2..182b22549b5 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -658,16 +658,14 @@ the C sources, too." (progn (insert (format-message " `%s'" handler)) (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) (help-xref-button 1 'help-function handler))) ;; FIXME: Obsolete since 24.4. (let ((lib (get function 'compiler-macro-file))) (when (stringp lib) (insert (format-message " in `%s'" lib)) (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) (help-xref-button 1 'help-function-cmacro function lib))))))) (unless (bolp) (insert ". See " @@ -734,7 +732,7 @@ the C sources, too." (insert (format (if (eq kind 'inferred) "\nInferred type: %s\n" - "\nType: %s\n") + "\nDeclared type: %s\n") type-spec)))) (fill-region fill-begin (point)) high-doc))))) @@ -1086,13 +1084,6 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; need to check macros before functions. (macrop function)) (concat beg "Lisp macro")) - ((atom def) - (let ((type (or (oclosure-type def) (cl-type-of def)))) - (concat beg (format "%s" - (make-text-button - (symbol-name type) nil - 'type 'help-type - 'help-args (list type)))))) ((keymapp def) (let ((is-full nil) (elts (cdr-safe def))) @@ -1102,7 +1093,16 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." elts nil)) (setq elts (cdr-safe elts))) (concat beg (if is-full "keymap" "sparse keymap")))) - (t "")))) + (t + (concat beg (format "%s" + (if (and (consp def) (symbolp (car def))) + (car def) + (let ((type (or (oclosure-type def) + (cl-type-of def)))) + (make-text-button + (symbol-name type) nil + 'type 'help-type + 'help-args (list type)))))))))) (with-current-buffer standard-output (insert description)) @@ -1130,8 +1130,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (setq help-mode--current-data (list :symbol function :file file-name)) (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) (help-xref-button 1 'help-function-def function file-name)))) (princ ".")))) @@ -1330,8 +1329,7 @@ it is displayed along with the global value." :file file-name)) (save-excursion (re-search-backward (substitute-command-keys - "`\\([^`']+\\)'") - nil t) + "`\\([^`']+\\)'")) (help-xref-button 1 'help-variable-def variable file-name))) (if valvoid @@ -1570,8 +1568,7 @@ This cancels value editing without updating the value." (princ (concat " You can " customize-label (or text " this variable."))) (with-current-buffer standard-output (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) + (re-search-backward (concat "\\(" customize-label "\\)")) (help-xref-button 1 'help-customize-variable variable))) (terpri)))) @@ -1801,8 +1798,7 @@ If FRAME is omitted or nil, use the selected frame." "\n\n")) (with-current-buffer standard-output (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) + (re-search-backward (concat "\\(" customize-label "\\)")) (help-xref-button 1 'help-customize-face f))) (setq file-name (find-lisp-object-file-name f 'defface)) (if (not file-name) @@ -1815,7 +1811,7 @@ If FRAME is omitted or nil, use the selected frame." ;; Make a hyperlink to the library. (save-excursion (re-search-backward - (substitute-command-keys "`\\([^`']+\\)'") nil t) + (substitute-command-keys "`\\([^`']+\\)'")) (help-xref-button 1 'help-face-def f file-name)) (princ ".") (terpri) @@ -1862,7 +1858,7 @@ If FRAME is omitted or nil, use the selected frame." (not (eq attr 'unspecified))) ;; Make a hyperlink to the parent face. (save-excursion - (re-search-backward ": \\([^:]+\\)" nil t) + (re-search-backward ": \\([^:]+\\)") (help-xref-button 1 'help-face attr))) (insert "\n"))) (terpri))) @@ -2113,9 +2109,7 @@ keymap value." "C source code" (help-fns-short-filename file-name)))) (save-excursion - (re-search-backward (substitute-command-keys - "`\\([^`']+\\)'") - nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) (setq help-mode--current-data (list :symbol keymap :file file-name)) (help-xref-button 1 'help-variable-def diff --git a/lisp/help.el b/lisp/help.el index 1ef46e394f3..616a45328fd 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -171,9 +171,15 @@ Value should be a list of elements, each element should of the form (GROUP-NAME (COMMAND . DESCRIPTION) (COMMAND . DESCRIPTION)...) -where GROUP-NAME is the name of the group of the commands, -COMMAND is the symbol of a command and DESCRIPTION is its short -description, 10 to 15 char5acters at most.") +where GROUP-NAME is the name of the group of the commands, COMMAND is +the symbol of a command and DESCRIPTION is its short description, 10 to +15 characters at most. The bindings for COMMAND are looked up from the +keymap specified in `help-quick-use-map'.") + +(defvar help-quick-use-map global-map + "Keymap that `help-quick' should use to lookup bindings. +Avoid changing the global value of this variable. Instead bind a +different map dynamically.") (declare-function prop-match-value "text-property-search" (match)) @@ -193,7 +199,7 @@ the documentation of the command bound to that key sequence." (let ((max-key-len 0) (max-cmd-len 0) keys) (dolist (ent (reverse (cdr section))) (catch 'skip - (let* ((bind (where-is-internal (car ent) nil t)) + (let* ((bind (where-is-internal (car ent) help-quick-use-map t)) (key (if bind (propertize (key-description bind) @@ -1043,6 +1049,9 @@ with `mouse-movement' events." (let ((enable-disabled-menus-and-buttons t) (cursor-in-echo-area t) (side-event nil) + ;; Showing the list of key sequences makes no sense when they + ;; asked about a key sequence. + (echo-keystrokes-help nil) saved-yank-menu) (unwind-protect (let (last-modifiers key-list) @@ -1060,8 +1069,11 @@ with `mouse-movement' events." ;; After a click, see if a double click is on the way. (and (memq 'click last-modifiers) (not (sit-for (/ (mouse-double-click-time) 1000.0) t)))) - (let* ((seq (read-key-sequence "\ + (let* ((prompt + (propertize "\ Describe the following key, mouse click, or menu item: " + 'face 'minibuffer-prompt)) + (seq (read-key-sequence prompt nil nil 'can-return-switch-frame)) (raw-seq (this-single-command-raw-keys)) (keyn (when (> (length seq) 0) @@ -2343,9 +2355,8 @@ the same names as used in the original source code, when possible." ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond - ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) + ((and (closurep def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) - ((eq (car-safe def) 'closure) (nth 2 def)) ((and (featurep 'native-compile) (subrp def) (listp (subr-native-lambda-list def))) diff --git a/lisp/hexl.el b/lisp/hexl.el index 1288cf4d7fb..28441a28d6e 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -256,10 +256,10 @@ as that will override any bit grouping options set here." ;;;###autoload (defun hexl-mode (&optional arg) - "\\<hexl-mode-map>A mode for editing binary files in hex dump format. -This is not an ordinary major mode; it alters some aspects + "A mode for editing binary files in hex dump format. +\\<hexl-mode-map>This is not an ordinary major mode; it alters some aspects of the current mode's behavior, but not all; also, you can exit -Hexl mode and return to the previous mode using `hexl-mode-exit'. +Hexl mode and return to the previous mode using \\[hexl-mode-exit]. This function automatically converts a buffer into the hexl format using the function `hexlify-buffer'. diff --git a/lisp/image.el b/lisp/image.el index d7496485aca..e973dff32c7 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -1423,115 +1423,142 @@ is recomputed to fit the newly transformed image." :type 'boolean :version "30.1") +(defsubst image--compute-rotation (image) + "Return the current rotation of IMAGE, or 0 if no rotation. +Also return nil if rotation is not a multiples of 90 degrees (0, 90, +180[-180] and 270[-90])." + (let ((degrees (or (image-property image :rotation) 0))) + (and (= 0 (mod degrees 1)) + (car (memql (truncate (mod degrees 360)) '(0 90 180 270)))))) + (defun image--compute-map (image) "Compute map for IMAGE suitable to be used as its :map property. -Return a copy of :original-image transformed based on IMAGE's :scale, +Return a copy of :original-map transformed based on IMAGE's :scale, :rotation, and :flip. When IMAGE's :original-map is nil, return nil. When :rotation is not a multiple of 90, return copy of :original-map." - (pcase-let* ((original-map (image-property image :original-map)) - (map (copy-tree original-map t)) - (scale (or (image-property image :scale) 1)) - (rotation (or (image-property image :rotation) 0)) - (flip (image-property image :flip)) - ((and size `(,width . ,height)) (image-size image t))) - (when (and ; Handle only 90-degree rotations - (zerop (mod rotation 1)) - (zerop (% (truncate rotation) 90))) - ;; SIZE fits MAP after transformations. Scale MAP before - ;; flip and rotate operations, since both need MAP to fit SIZE. - (image--scale-map map scale) + (when-let ((map (image-property image :original-map))) + (setq map (copy-tree map t)) + (let* ((size (image-size image t)) + ;; The image can be scaled for many reasons (:scale, + ;; :max-width, etc), so using `image--current-scaling' to + ;; calculate the current scaling is the correct method. But, + ;; since each call to `image_size' is expensive, the code is + ;; duplicated here to save the a call to `image-size'. + (scale (/ (float (car size)) + (car (image-size + (image--image-without-parameters image) t)))) + (rotation (image--compute-rotation image)) + ;; Image is flipped only if rotation is a multiple of 90, + ;; including 0. + (flip (and rotation (image-property image :flip)))) + ;; SIZE fits MAP after transformations. Scale MAP before flip and + ;; rotate operations, since both need MAP to fit SIZE. + (unless (= scale 1) + (image--scale-map map scale)) ;; In rendered images, rotation is always applied before flip. - (image--rotate-map - map rotation (if (or (= 90 rotation) (= 270 rotation)) + (when (memql rotation '(90 180 270)) + (image--rotate-map + map rotation (if (= rotation 180) + size ;; If rotated ±90°, swap width and height. - (cons height width) - size)) + (cons (cdr size) (car size))))) ;; After rotation, there's no need to swap width and height. - (image--flip-map map flip size)) + (when flip + (image--flip-map map size))) map)) (defun image--compute-original-map (image) "Return original map for IMAGE. If IMAGE lacks :map property, return nil. -When :rotation is not a multiple of 90, return copy of :map." - (when (image-property image :map) - (let* ((original-map (copy-tree (image-property image :map) t)) - (scale (or (image-property image :scale) 1)) - (rotation (or (image-property image :rotation) 0)) - (flip (image-property image :flip)) - (size (image-size image t))) - (when (and ; Handle only 90-degree rotations - (zerop (mod rotation 1)) - (zerop (% (truncate rotation) 90))) - ;; In rendered images, rotation is always applied before flip. - ;; To undo the transformation, flip before rotating. SIZE fits - ;; ORIGINAL-MAP before transformations are applied. Therefore, - ;; scale ORIGINAL-MAP after flip and rotate operations, since - ;; both need ORIGINAL-MAP to fit SIZE. - (image--flip-map original-map flip size) - (image--rotate-map original-map (- rotation) size) - (image--scale-map original-map (/ 1.0 scale))) - original-map))) +When there is no transformation, return copy of :map." + (when-let ((original-map (image-property image :map))) + (setq original-map (copy-tree original-map t)) + (let* ((size (image-size image t)) + ;; The image can be scaled for many reasons (:scale, + ;; :max-width, etc), so using `image--current-scaling' to + ;; calculate the current scaling is the correct method. But, + ;; since each call to `image_size' is expensive, the code is + ;; duplicated here to save the a call to `image-size'. + (scale (/ (float (car size)) + (car (image-size + (image--image-without-parameters image) t)))) + (rotation (image--compute-rotation image)) + ;; Image is flipped only if rotation is a multiple of 90 + ;; including 0. + (flip (and rotation (image-property image :flip)))) + ;; In rendered images, rotation is always applied before flip. + ;; To undo the transformation, flip before rotating. SIZE fits + ;; ORIGINAL-MAP before transformations are applied. Therefore, + ;; scale ORIGINAL-MAP after flip and rotate operations, since + ;; both need ORIGINAL-MAP to fit SIZE. + ;; In rendered images, rotation is always applied before flip. + (when flip + (image--flip-map original-map size)) + (when (memql rotation '(90 180 270)) + (image--rotate-map original-map (- rotation) size)) + (unless (= scale 1) + (image--scale-map original-map (/ 1.0 scale)))) + original-map)) (defun image--scale-map (map scale) "Scale MAP according to SCALE. Destructively modifies and returns MAP." - (unless (= 1 scale) - (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) - (pcase-exhaustive type - ('rect - (setf (caar coords) (round (* (caar coords) scale))) - (setf (cdar coords) (round (* (cdar coords) scale))) - (setf (cadr coords) (round (* (cadr coords) scale))) - (setf (cddr coords) (round (* (cddr coords) scale)))) - ('circle - (setf (caar coords) (round (* (caar coords) scale))) - (setf (cdar coords) (round (* (cdar coords) scale))) - (setcdr coords (round (* (cdr coords) scale)))) - ('poly - (dotimes (i (length coords)) - (aset coords i - (round (* (aref coords i) scale)))))))) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (setf (caar coords) (round (* (caar coords) scale))) + (setf (cdar coords) (round (* (cdar coords) scale))) + (setf (cadr coords) (round (* (cadr coords) scale))) + (setf (cddr coords) (round (* (cddr coords) scale)))) + ('circle + (setf (caar coords) (round (* (caar coords) scale))) + (setf (cdar coords) (round (* (cdar coords) scale))) + (setcdr coords (round (* (cdr coords) scale)))) + ('poly + (dotimes (i (length coords)) + (aset coords i + (round (* (aref coords i) scale))))))) map) (defun image--rotate-map (map rotation size) "Rotate MAP according to ROTATION and SIZE. +ROTATION must be a non-zero multiple of 90. Destructively modifies and returns MAP." - (unless (zerop rotation) - (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) - (pcase-exhaustive type - ('rect - (let ( x0 y0 ; New upper left corner - x1 y1) ; New bottom right corner - (pcase (truncate (mod rotation 360)) ; Set new corners to... - (90 ; ...old bottom left and upper right - (setq x0 (caar coords) y0 (cddr coords) - x1 (cadr coords) y1 (cdar coords))) - (180 ; ...old bottom right and upper left - (setq x0 (cadr coords) y0 (cddr coords) - x1 (caar coords) y1 (cdar coords))) - (270 ; ...old upper right and bottom left - (setq x0 (cadr coords) y0 (cdar coords) - x1 (caar coords) y1 (cddr coords)))) - (setcar coords (image--rotate-coord x0 y0 rotation size)) - (setcdr coords (image--rotate-coord x1 y1 rotation size)))) - ('circle - (setcar coords (image--rotate-coord - (caar coords) (cdar coords) rotation size))) - ('poly - (dotimes (i (length coords)) - (when (= 0 (% i 2)) - (pcase-let ((`(,x . ,y) - (image--rotate-coord - (aref coords i) (aref coords (1+ i)) rotation size))) - (aset coords i x) - (aset coords (1+ i) y)))))))) + (setq rotation (mod rotation 360)) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (let ( x0 y0 ; New upper left corner + x1 y1) ; New bottom right corner + (pcase rotation ; Set new corners to... + (90 ; ...old bottom left and upper right + (setq x0 (caar coords) y0 (cddr coords) + x1 (cadr coords) y1 (cdar coords))) + (180 ; ...old bottom right and upper left + (setq x0 (cadr coords) y0 (cddr coords) + x1 (caar coords) y1 (cdar coords))) + (270 ; ...old upper right and bottom left + (setq x0 (cadr coords) y0 (cdar coords) + x1 (caar coords) y1 (cddr coords)))) + (setcar coords (image--rotate-coord x0 y0 rotation size)) + (setcdr coords (image--rotate-coord x1 y1 rotation size)))) + ('circle + (setcar coords (image--rotate-coord + (caar coords) (cdar coords) rotation size))) + ('poly + (dotimes (i (length coords)) + (when (= 0 (% i 2)) + (pcase-let ((`(,x . ,y) + (image--rotate-coord + (aref coords i) (aref coords (1+ i)) rotation size))) + (aset coords i x) + (aset coords (1+ i) y))))))) map) (defun image--rotate-coord (x y angle size) "Rotate coordinates X and Y by ANGLE in image of SIZE. -ANGLE must be a multiple of 90. Returns a cons cell of rounded -coordinates (X1 Y1)." +ANGLE must be a multiple of 90 in [90 180 270]. Returns a cons cell of +rounded coordinates (X1 Y1)." (pcase-let* ((radian (* (/ angle 180.0) float-pi)) (`(,width . ,height) size) ;; y is positive, but we are in the bottom-right quadrant @@ -1552,25 +1579,24 @@ coordinates (X1 Y1)." (y1 (- y1))) (cons (round x1) (round y1)))) -(defun image--flip-map (map flip size) - "Horizontally flip MAP according to FLIP and SIZE. +(defun image--flip-map (map size) + "Horizontally flip MAP according to SIZE. Destructively modifies and returns MAP." - (when flip - (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) - (pcase-exhaustive type - ('rect - (let ((x0 (- (car size) (cadr coords))) - (y0 (cdar coords)) - (x1 (- (car size) (caar coords))) - (y1 (cddr coords))) - (setcar coords (cons x0 y0)) - (setcdr coords (cons x1 y1)))) - ('circle - (setf (caar coords) (- (car size) (caar coords)))) - ('poly - (dotimes (i (length coords)) - (when (= 0 (% i 2)) - (aset coords i (- (car size) (aref coords i))))))))) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (let ((x0 (- (car size) (cadr coords))) + (y0 (cdar coords)) + (x1 (- (car size) (caar coords))) + (y1 (cddr coords))) + (setcar coords (cons x0 y0)) + (setcdr coords (cons x1 y1)))) + ('circle + (setf (caar coords) (- (car size) (caar coords)))) + ('poly + (dotimes (i (length coords)) + (when (= 0 (% i 2)) + (aset coords i (- (car size) (aref coords i)))))))) map) (provide 'image) diff --git a/lisp/imenu.el b/lisp/imenu.el index f628936cedc..dd924b449cf 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -142,10 +142,17 @@ names work as tokens." (defcustom imenu-level-separator ":" "The separator between index names of different levels. -Used for making mouse-menu titles and for flattening nested indexes -with name concatenation." +Used for flattening nested indexes with name concatenation." :type 'string) +(defcustom imenu-flatten nil + "Whether to flatten the list of sections in an imenu or show it nested. +If non-nil, popup the completion buffer with a flattened menu. +The string from `imenu-level-separator' is used to separate names of +nested levels while flattening nested indexes with name concatenation." + :type 'boolean + :version "30.1") + (defcustom imenu-generic-skip-comments-and-strings t "When non-nil, ignore text inside comments and strings. Only affects `imenu-default-create-index-function' (and any @@ -763,6 +770,26 @@ Returns t for rescan and otherwise an element or subelement of INDEX-ALIST." menu))))) (popup-menu map event))) +(defun imenu--flatten-index-alist (index-alist &optional concat-names prefix) + ;; Takes a nested INDEX-ALIST and returns a flat index alist. + ;; If optional CONCAT-NAMES is non-nil, then a nested index has its + ;; name and a space concatenated to the names of the children. + ;; Third argument PREFIX is for internal use only. + (mapcan + (lambda (item) + (let* ((name (car item)) + (pos (cdr item)) + (new-prefix (and concat-names + (if prefix + (concat prefix imenu-level-separator name) + name)))) + (cond + ((or (markerp pos) (numberp pos)) + (list (cons new-prefix pos))) + (t + (imenu--flatten-index-alist pos concat-names new-prefix))))) + index-alist)) + (defun imenu-choose-buffer-index (&optional prompt alist) "Let the user select from a buffer index and return the chosen index. @@ -792,6 +819,8 @@ The returned value is of the form (INDEX-NAME . INDEX-POSITION)." ;; Create a list for this buffer only when needed. (while (eq result t) (setq index-alist (if alist alist (imenu--make-index-alist))) + (when imenu-flatten + (setq index-alist (imenu--flatten-index-alist index-alist t))) (setq result (if (and imenu-use-popup-menu (or (eq imenu-use-popup-menu t) mouse-triggered)) @@ -836,8 +865,6 @@ A trivial interface to `imenu-add-to-menubar' suitable for use in a hook." (interactive) (imenu-add-to-menubar "Index")) -(defvar imenu-buffer-menubar nil) - (defvar-local imenu-menubar-modified-tick 0 "Value of (buffer-chars-modified-tick) when `imenu-update-menubar' was called.") diff --git a/lisp/info.el b/lisp/info.el index 1e478cdbee9..c2c393cb243 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -807,30 +807,28 @@ Select the window used, if it has been made." (get-buffer-create "*info*"))))) (with-current-buffer buffer (unless (derived-mode-p 'Info-mode) - (Info-mode))) + (Info-mode)) - (let* ((window - (display-buffer buffer - (if other-window - '(nil (inhibit-same-window . t)) - '(display-buffer-same-window))))) - (with-current-buffer buffer - (if file-or-node - ;; If argument already contains parentheses, don't add another set - ;; since the argument will then be parsed improperly. This also - ;; has the added benefit of allowing node names to be included - ;; following the parenthesized filename. - (Info-goto-node - (if (and (stringp file-or-node) (string-match "(.*)" file-or-node)) - file-or-node - (concat "(" file-or-node ")"))) - (if (and (zerop (buffer-size)) - (null Info-history)) - ;; If we just created the Info buffer, go to the directory. - (Info-directory)))) + (if file-or-node + ;; If argument already contains parentheses, don't add another set + ;; since the argument will then be parsed improperly. This also + ;; has the added benefit of allowing node names to be included + ;; following the parenthesized filename. + (Info-goto-node + (if (and (stringp file-or-node) (string-match "(.*)" file-or-node)) + file-or-node + (concat "(" file-or-node ")"))) + (if (and (zerop (buffer-size)) + (null Info-history)) + ;; If we just created the Info buffer, go to the directory. + (Info-directory)))) + + (when-let ((window (display-buffer buffer + (if other-window + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window))))) + (select-window window)))) - (when window - (select-window window))))) ;;;###autoload (put 'info 'info-file (purecopy "emacs")) ;;;###autoload @@ -4063,8 +4061,8 @@ ERRORSTRING optional fourth argument, controls action on no match: (error "No %s around position %d" errorstring pos)))))))) (defun Info-mouse-follow-nearest-node (click) - "\\<Info-mode-map>Follow a node reference near point. -Like \\[Info-menu], \\[Info-follow-reference], \\[Info-next], \\[Info-prev] or \\[Info-up] command, depending on where you click. + "Follow a node reference near point. +\\<Info-mode-map>Like \\[Info-menu], \\[Info-follow-reference], \\[Info-next], \\[Info-prev] or \\[Info-up] command, depending on where you click. At end of the node's text, moves to the next node, or up if none." (interactive "e" Info-mode) (mouse-set-point click) @@ -4796,7 +4794,15 @@ Interactively, if the binding is `execute-extended-command', a command is read. The command is found by looking up in Emacs manual's indices or in another manual found via COMMAND's `info-file' property or the variable `Info-file-list-for-emacs'." - (interactive "kFind documentation for key: ") + (interactive + (let ((enable-disabled-menus-and-buttons t) + (cursor-in-echo-area t) + ;; Showing the list of key sequences makes no sense when they + ;; asked about a key sequence. + (echo-keystrokes-help nil) + (prompt (propertize "Find documentation for key: " + 'face 'minibuffer-prompt))) + (list (read-key-sequence prompt nil nil 'can-return-switch-frame)))) (let ((command (key-binding key))) (cond ((null command) (message "%s is undefined" (key-description key))) @@ -4878,6 +4884,19 @@ first line or header line, and for breadcrumb links.") ;; 'font-lock-face 'header-line line) line)) +(defvar Info--dont-hide-references + '(("texinfo" "Cross Reference Commands")) + "Manuals and nodes where `Info-hide-note-references' should be ignored. +This is an alist whose elements should be of the form + + (MANUAL NODE...) + +where MANUAL is the basename of an Info manual's main file, and NODEs +are one or more nodes in MANUAL where info.el should not hide +cross-references even in `Info-hide-note-references' is non-nil. +This is because some rare nodes describe how cross-references work, +and so should be rendered as makeinfo produced them.") + (defun Info-fontify-node () "Fontify the node." (save-excursion @@ -4895,6 +4914,16 @@ first line or header line, and for breadcrumb links.") (or (eq Info-fontify-maximum-menu-size t) (< (- (point-max) (point-min)) Info-fontify-maximum-menu-size)))) + ;; Disable Info-hide-note-references in nodes that are + ;; incompatible with that feature. + (Info-hide-note-references + (if (member Info-current-node + (assoc-string + (file-name-sans-extension + (file-name-nondirectory Info-current-file)) + Info--dont-hide-references)) + nil + Info-hide-note-references)) rbeg rend) ;; Fontify header line diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el index 86429f15f7c..ce1f6c1d592 100644 --- a/lisp/international/textsec.el +++ b/lisp/international/textsec.el @@ -395,7 +395,7 @@ suspicious by, respectively, `textsec-local-address-suspicious-p' and `textsec-domain-suspicious-p'." (pcase-let ((`(,local ,domain) (split-string address "@"))) (or - (textsec-domain-suspicious-p domain) + (if domain (textsec-domain-suspicious-p domain)) (textsec-local-address-suspicious-p local)))) (defun textsec-email-address-header-suspicious-p (email) @@ -417,7 +417,7 @@ and `textsec-name-suspicious-p'." (mail-header-parse-address email t) (error (throw 'end "Email address can't be parsed."))))) (or - (textsec-email-address-suspicious-p address) + (and address (textsec-email-address-suspicious-p address)) (and name (textsec-name-suspicious-p name)))))) (defun textsec-url-suspicious-p (url) diff --git a/lisp/isearch.el b/lisp/isearch.el index a139a6fb84e..e8fb33ef6ea 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2800,8 +2800,8 @@ With argument, add COUNT copies of the character." (let ((string (if (and (integerp count) (> count 1)) (make-string count char) (char-to-string char)))) - (setq isearch-new-string (concat isearch-string string) - isearch-new-message (concat isearch-message + (setq isearch-new-string (concat isearch-new-string string) + isearch-new-message (concat isearch-new-message (mapconcat 'isearch-text-char-description string "")))))))) @@ -2822,8 +2822,8 @@ The command accepts Unicode names like \"smiling face\" or (when (and (integerp count) (> count 1)) (setq emoji (apply 'concat (make-list count emoji)))) (when emoji - (setq isearch-new-string (concat isearch-string emoji) - isearch-new-message (concat isearch-message + (setq isearch-new-string (concat isearch-new-string emoji) + isearch-new-message (concat isearch-new-message (mapconcat 'isearch-text-char-description emoji ""))))))) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 5037d8c5b2b..9e9a5f97fd4 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -591,15 +591,18 @@ connection object, called when the process dies.") (cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection) &optional cleanup) "Wait for JSONRPC connection CONN to shutdown. -With optional CLEANUP, kill any associated buffers." +With optional CLEANUP, kill any associated buffers. +If CONN is not shutdown within a reasonable amount of time, warn +and delete the network process." (unwind-protect (cl-loop with proc = (jsonrpc--process conn) for i from 0 while (not (process-get proc 'jsonrpc-sentinel-cleanup-started)) unless (zerop i) do (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc) - do (delete-process proc) + do + ;; Let sentinel have a chance to run (accept-process-output nil 0.1)) (when cleanup (kill-buffer (process-buffer (jsonrpc--process conn))) diff --git a/lisp/keymap.el b/lisp/keymap.el index b2b475c7d71..cbd26f1060e 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -603,10 +603,11 @@ non-nil, all commands in the map will have the `repeat-map' symbol property. More control is available over which commands are repeatable; the -value can also be a property list with properties `:enter' and -`:exit', for example: +value can also be a property list with properties `:enter', +`:exit' and `:hints', for example: - :repeat (:enter (commands ...) :exit (commands ...)) + :repeat (:enter (commands ...) :exit (commands ...) + :hints ((command . \"hint\") ...)) `:enter' specifies the list of additional commands that only enter `repeat-mode'. When the list is empty, then only the @@ -621,6 +622,10 @@ Specifying a list of commands is useful when those commands exist in this specific map, but should not have the `repeat-map' symbol property. +`:hints' is a list of cons pairs where car is a command and +cdr is a string that is displayed alongside of the repeatable key +in the echo area. + \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP REPEAT &rest [KEY DEFINITION]...)" (declare (indent 1)) (let ((opts nil) @@ -660,7 +665,9 @@ property. (setq def (pop defs)) (when (and (memq (car def) '(function quote)) (not (memq (cadr def) (plist-get repeat :exit)))) - (push `(put ,def 'repeat-map ',variable-name) props))))) + (push `(put ,def 'repeat-map ',variable-name) props))) + (dolist (def (plist-get repeat :hints)) + (push `(put ',(car def) 'repeat-hint ',(cdr def)) props)))) (let ((defvar-form `(defvar ,variable-name diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 897ebf14330..07a13d5632c 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -342,7 +342,7 @@ information." (setq kmacro-last-counter kmacro-counter kmacro-counter (if (and current-prefix-arg (listp current-prefix-arg)) last - kmacro-counter (+ kmacro-counter arg)))) + (+ kmacro-counter arg)))) (unless executing-kbd-macro (kmacro-display-counter))) @@ -1388,6 +1388,564 @@ To customize possible responses, change the \"bindings\" in (let ((executing-kbd-macro nil)) (redisplay)))) +;;; Mode and commands for working with the ring in a table + +(defface kmacro-menu-mark '((t (:inherit font-lock-constant-face))) + "Face used for the Keyboard Macro Menu marks." + :group 'kmacro + :version "30.1") + +(defface kmacro-menu-flagged '((t (:inherit error))) + "Face used for keyboard macros flagged for deletion." + :group 'kmacro + :version "30.1") + +(defface kmacro-menu-marked '((t (:inherit warning))) + "Face used for keyboard macros marked for duplication." + :group 'kmacro + :version "30.1") + +(defvar-keymap kmacro-menu-mode-map + :doc "Keymap for `kmacro-menu-mode'." + :parent tabulated-list-mode-map + "#" #'kmacro-menu-edit-position + "c" #'kmacro-menu-edit-counter + "e" #'kmacro-menu-edit-keys + "f" #'kmacro-menu-edit-format + "RET" #'kmacro-menu-edit-column + + "C" #'kmacro-menu-do-copy + "D" #'kmacro-menu-do-delete + "m" #'kmacro-menu-mark + + "d" #'kmacro-menu-flag-for-deletion + "x" #'kmacro-menu-do-flagged-delete + + "u" #'kmacro-menu-unmark + "U" #'kmacro-menu-unmark-all + "DEL"#'kmacro-menu-unmark-backward + + "<remap> <transpose-lines>" #'kmacro-menu-transpose) + +(define-derived-mode kmacro-menu-mode tabulated-list-mode + "Keyboard Macro Menu" + "Major mode for listing and editing keyboard macros." + (make-local-variable 'kmacro-menu--marks) + (make-local-variable 'kmacro-menu--deletion-flags) + (setq-local tabulated-list-format + [("Position" 8 nil) + ("Counter" 8 nil :right-align t :pad-right 2) + ("Format" 8 nil) + ("Formatted" 10 nil) + ("Keys" 1 nil)]) + (setq-local tabulated-list-padding 2) + (add-hook 'tabulated-list-revert-hook #'kmacro-menu--refresh nil t) + (tabulated-list-init-header) + (unless (kmacro-ring-empty-p) + (kmacro-menu--refresh) + (tabulated-list-print))) + +;;;###autoload +(defalias 'kmacro-menu #'list-keyboard-macros) +;;;###autoload +(defun list-keyboard-macros () + "List the keyboard macros." + (interactive) + (let ((buf (get-buffer-create "*Keyboard Macro List*"))) + (with-current-buffer buf + (kmacro-menu-mode)) + (pop-to-buffer buf))) + +;;;; Utility functions and mode data + +(defvar kmacro-menu--deletion-flags nil + "Alist of entries flagged for deletion.") + +(defvar kmacro-menu--marks nil + "Alist of entries marked for copying and duplication.") + +(defun kmacro-menu--id-kmacro (entry-id) + "Return the keyboard macro that is part of the ENTRY-ID." + (car entry-id)) + +(defun kmacro-menu--id-position (entry-id) + "Return the ordinal position that is part of the ENTRY-ID." + (cdr entry-id)) + +(defun kmacro-menu--kmacros () + "Return the list of the existing keyboard macros or nil, if none are defined." + (when last-kbd-macro + (cons (kmacro-ring-head) + kmacro-ring))) + +(defun kmacro-menu--refresh () + "Reset the list of keyboard macros." + (setq-local tabulated-list-entries + (seq-map-indexed (lambda (km idx) + (let ((cnt (kmacro--counter km)) + (fmt (kmacro--format km))) + `((,km . ,idx) + [,(format "%d" idx) + ,(format "%d" cnt) + ,fmt + ,(format fmt cnt) + ,(format-kbd-macro (kmacro--keys km))]))) + (kmacro-menu--kmacros)) + kmacro-menu--deletion-flags nil + kmacro-menu--marks nil) + (tabulated-list-clear-all-tags)) + +(defun kmacro-menu--map-ids (function) + "Apply FUNCTION to the current table's entry IDs in order. + +Return a list of the output of FUNCTION." + (mapcar function + (mapcar #'car + (seq-sort-by #'cdar #'< tabulated-list-entries)))) + +(defun kmacro-menu--replace-all (kmacros) + "Replace the existing keyboard macros with those in KMACROS. + +The first element in the list overwrites the values of `last-kbd-macro', +`kmacro-counter', and `kmacro-counter-format'. The remaining elements +become the value of `kmacro-ring'. + +KMACROS is a list of `kmacro' objects." + (if (null kmacros) + (setq last-kbd-macro nil + kmacro-counter-format kmacro-default-counter-format + kmacro-counter 0 + kmacro-ring nil) + (if (not (seq-every-p #'kmacro-p kmacros)) + (error "All elements must satisfy `kmacro-p'") + (kmacro-split-ring-element (car kmacros)) + (setq kmacro-ring (cdr kmacros))))) + +(defun kmacro-menu--replace-at (kmacro n) + "Replace the keyboard macro at position N with KMACRO. + +This function replaces all of the existing keyboard macros via +`kmacro-menu--replace-all'. Except for the macro at position N, which will +be KMACRO, the replacement macros are the existing macros identified in +the table." + (kmacro-menu--replace-all + (kmacro-menu--map-ids (lambda (id) + (if (= n (kmacro-menu--id-position id)) + kmacro + (kmacro-menu--id-kmacro id)))))) + +(defun kmacro-menu--query-revert () + "If the table differs from the existing macros, ask whether to revert table." + (when (and (not (equal (kmacro-menu--kmacros) + (kmacro-menu--map-ids #'kmacro-menu--id-kmacro))) + (yes-or-no-p "Table does not match existing keyboard macros. Stop and revert table?")) + (tabulated-list-revert) + (signal 'quit nil))) + +(defun kmacro-menu--assert-row (&optional id) + "Signal an error if point is not on a table row. + +ID is the tabulated list id of the supposed entry at point." + (unless (or id (tabulated-list-get-id)) + (user-error "Not on a table row"))) + +(defun kmacro-menu--propertize-keys (face) + "Redisplay the macro keys on the current line with FACE." + (tabulated-list-set-col 4 (propertize (aref (tabulated-list-get-entry) 4) + 'face face))) + +(defun kmacro-menu--do-region (function) + "Run FUNCTION on macros in the region or on the current line at the line start. + +If there is an active region, for each line in the region, move to the +beginning of the line and apply FUNCTION to the table entry ID of the +line. If there is no region, apply FUNCTION only to the table entry ID +of the current line. + +When there is no active region, advance to the beginning of the next +line after applying FUNCTION." + (if (use-region-p) + (save-excursion + (let* ((reg-beg (region-beginning)) + (reg-end (region-end)) + (line-beg (progn + (goto-char reg-beg) + (pos-bol))) + (line-end (progn + (goto-char reg-end) + (if (bolp) + reg-end + (pos-bol 2))))) + (goto-char line-beg) + (let ((id)) + (while (and (< (point) line-end) + (setq id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (funcall function id) + (forward-line 1))))) + (let ((id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (goto-char (pos-bol)) + (funcall function id) + (forward-line 1)))) + +(defun kmacro-menu--marks-exist-p () + "Return non-nil if markers exist for any table entries." + (let ((tag (gensym))) + (catch tag + (kmacro-menu--map-ids (lambda (id) + (when (alist-get (kmacro-menu--id-position id) + kmacro-menu--marks) + (throw tag t)))) + nil))) + +;;;; Commands for Marks and Flags + +(defun kmacro-menu-mark () + "Mark macros in the region or on the current line. + +If there's an active region, mark macros in the region; otherwise mark +the macro on the current line. If marking the current line, move point +to the next line when done. + +Marked macros can be operated on by `kmacro-menu-do-copy' and +`kmacro-menu-do-delete'." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (kmacro-menu--do-region + (lambda (id) + (setf (alist-get (kmacro-menu--id-position id) + kmacro-menu--marks) + t) + (kmacro-menu--propertize-keys 'kmacro-menu-marked) + (tabulated-list-put-tag #("*" 0 1 (face kmacro-menu-mark)))))) + +(defun kmacro-menu-flag-for-deletion () + "Flag macros in the region or on the current line. + +If there's an active region, flag macros in the region; otherwise flag +the macro on the current line. If there is no active region, move point +to the next line when done. + +Flagged macros can be deleted via `kmacro-menu-do-flagged-delete'." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (kmacro-menu--do-region + (lambda (id) + (setf (alist-get (kmacro-menu--id-position id) + kmacro-menu--deletion-flags) + t) + (kmacro-menu--propertize-keys 'kmacro-menu-flagged) + (tabulated-list-put-tag #("D" 0 1 (face kmacro-menu-mark)))))) + +(defun kmacro-menu-unmark () + "Unmark and unflag macros in the region or on the current line. + +If there's an active region, unmark and unflag macros in the region; +otherwise unmark and unflag the macro on the current line. If there is +no active region, move point to the next line when done." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (kmacro-menu--do-region + (lambda (id) + (let ((pos (kmacro-menu--id-position id))) + (setf (alist-get pos kmacro-menu--deletion-flags) nil + (alist-get pos kmacro-menu--marks) nil)) + (kmacro-menu--propertize-keys 'default) + (tabulated-list-put-tag " ")))) + +(defun kmacro-menu-unmark-backward () + "Like `kmacro-menu-unmark', but move backwards instead of forwards." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (let ((go-back (not (use-region-p)))) + (kmacro-menu-unmark) + (when go-back + (forward-line -2)))) + +(defun kmacro-menu-unmark-all () + "Unmark and unflag all listed keyboard macros." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (setq-local kmacro-menu--deletion-flags nil + kmacro-menu--marks nil) + (save-excursion + (goto-char (point-min)) + (while (tabulated-list-get-id) + (kmacro-menu--propertize-keys 'default) + (forward-line 1)) + (tabulated-list-clear-all-tags))) + +;;;; Commands that Modify the Ring + +(defun kmacro-menu-do-flagged-delete () + "Delete keyboard macros flagged via `kmacro-menu-flag-for-deletion'." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (let ((res) + (num-deletes 0)) + (kmacro-menu--map-ids (lambda (id) + (if (alist-get (kmacro-menu--id-position id) + kmacro-menu--deletion-flags) + (setq num-deletes (1+ num-deletes)) + (push (kmacro-menu--id-kmacro id) res)))) + (when (yes-or-no-p (if (= 1 num-deletes) + "Delete 1 flagged keyboard macro?" + (format "Delete %d flagged keyboard macros?" + num-deletes))) + (kmacro-menu--replace-all + (nreverse res)) + (tabulated-list-revert)))) + +(defun kmacro-menu-do-copy () + "Duplicate macros in the region, those with markers, or the one at point. + +Macros are duplicated at their current position in the macro ring. + +If there's an active region, duplicate macros in the region; otherwise +duplicate the marked macros or, if there are no marks, the macro on the +current line." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (let* ((region-exists (use-region-p)) + (mark-exists (kmacro-menu--marks-exist-p)) + (id-alist (if (or region-exists + (not mark-exists)) + (let ((region-alist)) + (kmacro-menu--do-region + (lambda (id) + (push (cons (kmacro-menu--id-position id) + t) + region-alist))) + region-alist) + kmacro-menu--marks)) + (num-duplicates 0)) + (let ((res)) + (kmacro-menu--map-ids (lambda (id) + (let ((pos (kmacro-menu--id-position id)) + (km (kmacro-menu--id-kmacro id))) + (push km res) + (when (alist-get pos id-alist) + (push km res) + (setq num-duplicates (1+ num-duplicates)))))) + ;; Confirm the action if we operated on marks or the region, but + ;; don't confirm if operating on a single line without a region. + (when (if (or mark-exists region-exists) + (yes-or-no-p (if (= 1 num-duplicates) + "Copy (duplicate) 1 keyboard macro?" + (format "Copy (duplicate) %d keyboard macros?" + num-duplicates))) + t) + (kmacro-menu--replace-all (nreverse res)) + (tabulated-list-revert))))) + +(defun kmacro-menu-do-delete () + "Delete macros in the region, those with markers, or the one at point. + +If there's an active region, delete macros in the region; otherwise +delete the marked macros or, if there are no marks, the macro on the +current line." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--query-revert) + (let ((num-deletes 0) + (id-alist (if (or (use-region-p) + (not (kmacro-menu--marks-exist-p))) + (let ((region-alist)) + (kmacro-menu--do-region + (lambda (id) + (push (cons (kmacro-menu--id-position id) + t) + region-alist))) + region-alist) + kmacro-menu--marks))) + (let ((res)) + (kmacro-menu--map-ids (lambda (id) + (if (alist-get (kmacro-menu--id-position id) + id-alist) + (setq num-deletes (1+ num-deletes)) + (push (kmacro-menu--id-kmacro id) res)))) + (when (yes-or-no-p (if (= 1 num-deletes) + "Delete 1 keyboard macro?" + (format "Delete %d keyboard macros?" + num-deletes))) + (kmacro-menu--replace-all (nreverse res)) + (tabulated-list-revert))))) + +;;;; Commands that Modify a Keyboard Macro + +(defun kmacro-menu-edit-position () + "Move the keyboard macro at point to a new position. + +See the Info node `(emacs) Keyboard Macro Ring' for more information." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (let ((id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (kmacro-menu--query-revert) + (let* ((new-position (min (length tabulated-list-entries) + (max 0 + (read-number "New position: " 0)))) + (old-km (kmacro-menu--id-kmacro id)) + (old-pos (kmacro-menu--id-position id))) + (unless (= old-pos new-position) + (kmacro-menu--replace-all + (let ((res) + (true-new-pos (if (> new-position old-pos) + (1+ new-position) + new-position))) + (kmacro-menu--map-ids (lambda (this-id) + (let ((this-km (kmacro-menu--id-kmacro this-id)) + (this-pos (kmacro-menu--id-position this-id))) + (unless (= old-pos this-pos) + (when (= this-pos true-new-pos) + (push old-km res)) + (push this-km res))))) + (when (>= true-new-pos + (length tabulated-list-entries)) + (push old-km res)) + (nreverse res))) + (tabulated-list-revert))))) + +(defun kmacro-menu-transpose () + "Swap the keyboard macro at point with the one above, then move to the next line. + +If point is on the first line (position number 0), then swap the macros +at position numbers 0 and 1, then move point to the third line. + +Note that this is the earlier position in the ring, not the sorted +table." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (let ((id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (kmacro-menu--query-revert) + (let* ((old-pos (kmacro-menu--id-position id)) + (first-line (= 0 old-pos)) + (end-lines-forward (if first-line + 2 + (+ 3 old-pos)))) + ;; When transposing the first two macros, we don't use + ;; `kmacro-swap-ring' here because it is possible for the user to + ;; choose to not refresh the table when it is out of date. + (kmacro-menu--replace-all + (let ((res)) + (kmacro-menu--map-ids + (if first-line + (let ((old-km (kmacro-menu--id-kmacro id))) + (lambda (this-id) + (let ((this-pos (kmacro-menu--id-position this-id))) + (unless (= 0 this-pos) + (push (kmacro-menu--id-kmacro this-id) res) + (when (= 1 this-pos) + (push old-km res)))))) + (let ((new-pos (1- old-pos))) + (lambda (this-id) + (let ((this-pos (kmacro-menu--id-position this-id))) + (unless (= old-pos this-pos) + (when (= new-pos this-pos) + (push (kmacro-menu--id-kmacro id) res)) + (push (kmacro-menu--id-kmacro this-id) res))))))) + (nreverse res))) + (tabulated-list-revert) + (goto-char (point-min)) + (forward-line end-lines-forward)))) + +(defun kmacro-menu-edit-format () + "Edit the counter format of the keyboard macro at point. + +Valid counter formats are those for integers accepted by the function +`format'. + +See the command `kmacro-set-format' and the Info node `(emacs) Keyboard +Macro Counter' for more information." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (let ((id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (kmacro-menu--query-revert) + (let ((km (kmacro-menu--id-kmacro id))) + (kmacro-menu--replace-at + (kmacro (kmacro--keys km) + (kmacro--counter km) + (read-string "New format: " nil nil + (list kmacro-default-counter-format + (kmacro--format km)))) + (kmacro-menu--id-position id)) + (tabulated-list-revert)))) + +(defun kmacro-menu-edit-counter () + "Edit the counter of the keyboard macro at point. + +See Info node `(emacs) Keyboard Macro Counter' for more +information." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (let ((id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (kmacro-menu--query-revert) + (let ((km (kmacro-menu--id-kmacro id))) + (kmacro-menu--replace-at + (kmacro (kmacro--keys km) + (read-number "New counter: " + (list 0 + (kmacro--counter + (kmacro-menu--id-kmacro id)))) + (kmacro--format km)) + (kmacro-menu--id-position id)) + (tabulated-list-revert)))) + +(defun kmacro-menu-edit-keys () + "Edit the keys of the keyboard macro at point via `edmacro-mode'. + +See Info node `(emacs) Edit Keyboard Macro' for more +information." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (let ((id (tabulated-list-get-id))) + (kmacro-menu--assert-row id) + (kmacro-menu--query-revert) + (let* ((old-km (kmacro-menu--id-kmacro id))) + (edit-kbd-macro (kmacro--keys old-km) + nil + nil + (lambda (mac) + (kmacro-menu--replace-at + (kmacro mac + (kmacro--counter old-km) + (kmacro--format old-km)) + (kmacro-menu--id-position id)) + (tabulated-list-revert)))))) + +(defun kmacro-menu-edit-column () + "Edit the value in the current column of the keyboard macro at point." + (declare (modes kmacro-menu-mode)) + (interactive nil kmacro-menu-mode) + (kmacro-menu--assert-row) + (kmacro-menu--query-revert) + (pcase (get-text-property (point) 'tabulated-list-column-name) + ('nil (let ((pos (point))) + ;; If we didn't find a column, try moving forwards or + ;; backwards to the nearest column. + (tabulated-list-next-column 1) + (when (= pos (point)) + (tabulated-list-previous-column 1)) + (if (null (get-text-property (point) 'tabulated-list-column-name)) + (user-error "No column at point") + (kmacro-menu-edit-column)))) + ("Position" (call-interactively #'kmacro-menu-edit-position)) + ("Counter" (call-interactively #'kmacro-menu-edit-counter)) + ("Format" (call-interactively #'kmacro-menu-edit-format)) + ("Formatted" (user-error "Formatted counter is not editable")) + ("Keys" (call-interactively #'kmacro-menu-edit-keys)))) + (provide 'kmacro) ;;; kmacro.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index b434ee0e37f..8f9b11e3df1 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1453,7 +1453,19 @@ point is moved into the passwords (see `authinfo-hide-elements'). \\{authinfo-mode-map} (fn)" t) -(register-definition-prefixes "auth-source" '("auth")) +(autoload 'read-passwd "auth-source" "\ +Read a password, prompting with PROMPT, and return it. +If optional CONFIRM is non-nil, read the password twice to make sure. +Optional DEFAULT is a default password to use instead of empty input. + +This function echoes `*' for each character that the user types. +You could let-bind `read-hide-char' to another hiding character, though. + +Once the caller uses the password, it can erase the password +by doing (clear-string STRING). + +(fn PROMPT &optional CONFIRM DEFAULT)") +(register-definition-prefixes "auth-source" '("auth" "read-passwd-")) ;;; Generated autoloads from auth-source-pass.el @@ -2452,8 +2464,8 @@ The variables `browse-url-browser-function', `browse-url-handlers', and `browse-url-default-handlers' determine which browser function to use. -This command prompts for a URL, defaulting to the URL at or -before point. +Interactively, this command prompts for a URL, defaulting to the +URL at or before point. The additional ARGS are passed to the browser function. See the doc strings of the actual functions, starting with @@ -2461,7 +2473,9 @@ doc strings of the actual functions, starting with significance of ARGS (most of the functions ignore it). If ARGS are omitted, the default is to pass -`browse-url-new-window-flag' as ARGS. +`browse-url-new-window-flag' as ARGS. Interactively, pass the +prefix arg as ARGS; if `browse-url-new-window-flag' is non-nil, +invert the prefix arg instead. (fn URL &rest ARGS)" t) (autoload 'browse-url-at-point "browse-url" "\ @@ -2945,7 +2959,7 @@ Major mode for editing C, powered by tree-sitter. This mode is independent from the classic cc-mode.el based `c-mode', so configuration variables of that mode, like -`c-basic-offset', doesn't affect this mode. +`c-basic-offset', don't affect this mode. To use tree-sitter C/C++ modes by default, evaluate @@ -2954,7 +2968,7 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration. +in your init files. (fn)" t) (autoload 'c++-ts-mode "c-ts-mode" "\ @@ -2971,7 +2985,7 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration. +in your init files. Since this mode uses a parser, unbalanced brackets might cause some breakage in indentation/fontification. Therefore, it's @@ -2987,7 +3001,7 @@ matching on file name insufficient for detecting major mode that should be used. This function attempts to use file contents to determine whether -the code is C or C++ and based on that chooses whether to enable +the code is C or C++, and based on that chooses whether to enable `c-ts-mode' or `c++-ts-mode'." t) (make-obsolete 'c-or-c++-ts-mode 'c-or-c++-mode "30.1") (register-definition-prefixes "c-ts-mode" '("c-ts-")) @@ -5320,6 +5334,48 @@ The mode's hook is called both when the mode is enabled and when it is disabled. (fn &optional ARG)" t) +(put 'global-completion-preview-mode 'globalized-minor-mode t) +(defvar global-completion-preview-mode nil "\ +Non-nil if Global Completion-Preview mode is enabled. +See the `global-completion-preview-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 `global-completion-preview-mode'.") +(custom-autoload 'global-completion-preview-mode "completion-preview" nil) +(autoload 'global-completion-preview-mode "completion-preview" "\ +Toggle Completion-Preview mode in all buffers. +With prefix ARG, enable Global Completion-Preview mode if ARG is +positive; otherwise, disable it. + +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. + +Completion-Preview mode is enabled in all buffers where +`completion-preview-mode' would do it. + +See `completion-preview-mode' for more information on +Completion-Preview mode. + +`global-completion-preview-modes' is used to control which modes this +minor mode is used in. + +(fn &optional ARG)" t) +(defvar global-completion-preview-modes '((not minibuffer-mode special-mode) t) "\ +Which major modes `completion-preview-mode' is switched on in. +This variable can be either t (all major modes), nil (no major modes), +or a list of modes and (not modes) to switch use this minor mode or +not. For instance + + (c-mode (not message-mode mail-mode) text-mode) + +means \"use this mode in all modes derived from `c-mode', don't use in +modes derived from `message-mode' or `mail-mode', but do use in other +modes derived from `text-mode'\". An element with value t means \"use\" +and nil means \"don't use\". There's an implicit nil at the end of the +list.") +(custom-autoload 'global-completion-preview-modes "completion-preview" t) (register-definition-prefixes "completion-preview" '("completion-preview-")) @@ -13270,7 +13326,7 @@ For instance: (?l . \"ls\"))) Each %-spec may contain optional flag, width, and precision -modifiers, as follows: +specifiers, as follows: %<flags><width><precision>character @@ -13283,7 +13339,7 @@ The following flags are allowed: * ^: Convert to upper case. * _: Convert to lower case. -The width and truncation modifiers behave like the corresponding +The width and precision specifiers behave like the corresponding ones in `format' when applied to %s. For example, \"%<010b\" means \"substitute into the output the @@ -15684,6 +15740,17 @@ Produce an nroff buffer containing the doc-strings from the DOC file. Produce a texinfo buffer with sorted doc-strings from the DOC file. (fn FILE)" t) +(autoload 'help-fns-function-name "help-fns" "\ +Return a short buttonized string representing FUNCTION. +The string is propertized with a button; clicking on that +provides further details about FUNCTION. +FUNCTION can be a function, a built-in, a keyboard macro, +or a compile function. +This function is intended to be used to display various +callable symbols in buffers in a way that allows the user +to find out more details about the symbols. + +(fn FUNCTION)") (register-definition-prefixes "help-fns" '("describe-" "help-" "keymap-name-history")) @@ -15696,6 +15763,10 @@ window listing and describing the options. A value of nil means skip the middle step, so that \\[help-command] \\[help-command] gives the window that lists the options.") (custom-autoload 'three-step-help "help-macro" t) +(autoload 'help--help-screen "help-macro" "\ + + +(fn HELP-LINE HELP-TEXT HELPED-MAP BUFFER-NAME)") (register-definition-prefixes "help-macro" '("make-help-screen")) @@ -15810,10 +15881,10 @@ Provide help for current mode." t) ;;; Generated autoloads from hexl.el (autoload 'hexl-mode "hexl" "\ -\\<hexl-mode-map>A mode for editing binary files in hex dump format. -This is not an ordinary major mode; it alters some aspects +A mode for editing binary files in hex dump format. +\\<hexl-mode-map>This is not an ordinary major mode; it alters some aspects of the current mode's behavior, but not all; also, you can exit -Hexl mode and return to the previous mode using `hexl-mode-exit'. +Hexl mode and return to the previous mode using \\[hexl-mode-exit]. This function automatically converts a buffer into the hexl format using the function `hexlify-buffer'. @@ -19132,7 +19203,7 @@ Major mode for editing JSON, powered by tree-sitter. ;;; Generated autoloads from jsonrpc.el -(push (purecopy '(jsonrpc 1 0 24)) package--builtin-versions) +(push (purecopy '(jsonrpc 1 0 25)) package--builtin-versions) (register-definition-prefixes "jsonrpc" '("jsonrpc-")) @@ -29970,24 +30041,6 @@ For example: to sort lines in the region by the first word on each line RECORD-REGEXP would be \"^.*$\" and KEY would be \"\\\\=\\<f\\\\w*\\\\>\" (fn REVERSE RECORD-REGEXP KEY-REGEXP BEG END)" t) -(autoload 'sort-on "sort" "\ -Sort SEQUENCE by calling PREDICATE on sort keys produced by ACCESSOR. -SEQUENCE should be the input sequence to sort. -Elements of SEQUENCE are sorted by keys which are obtained by -calling ACCESSOR on each element. ACCESSOR should be a function of -one argument, an element of SEQUENCE, and should return the key -value to be compared by PREDICATE for sorting the element. -PREDICATE is the function for comparing keys; it is called with two -arguments, the keys to compare, and should return non-nil if the -first key should sort before the second key. -The return value is always a new list. -This function has the performance advantage of evaluating -ACCESSOR only once for each element in the input SEQUENCE, and is -therefore appropriate when computing the key by ACCESSOR is an -expensive operation. This is known as the \"decorate-sort-undecorate\" -paradigm, or the Schwartzian transform. - -(fn SEQUENCE PREDICATE ACCESSOR)") (autoload 'sort-columns "sort" "\ Sort lines in region alphabetically by a certain range of columns. For the purpose of this command, the region BEG...END includes @@ -33382,7 +33435,7 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from transient.el -(push (purecopy '(transient 0 5 2)) package--builtin-versions) +(push (purecopy '(transient 0 6 0)) package--builtin-versions) (autoload 'transient-insert-suffix "transient" "\ Insert a SUFFIX into PREFIX before LOC. PREFIX is a prefix command, a symbol. @@ -37831,6 +37884,11 @@ run a specific program. The program must be a member of (register-definition-prefixes "tramp-androidsu" '("tramp-androidsu-")) +;;; Generated autoloads from progmodes/peg.el + +(push (purecopy '(peg 1 0 1)) package--builtin-versions) +(register-definition-prefixes "peg" '("bob" "bol" "bos" "bow" "define-peg-rule" "eob" "eol" "eos" "eow" "fail" "null" "peg" "with-peg-rules")) + ;;; End of scraped data (provide 'loaddefs) @@ -37838,8 +37896,8 @@ run a specific program. The program must be a member of ;; Local Variables: ;; version-control: never ;; no-update-autoloads: t -;; no-native-compile: t ;; no-byte-compile: t +;; no-native-compile: t ;; coding: utf-8-emacs-unix ;; End: diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 89f0238cf74..ae4a43797f0 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -328,11 +328,39 @@ not contain `d', so that a full listing is expected." full-directory-p) (let* ((dir (file-name-as-directory file)) (default-directory dir) ; so that file-attributes works + (id-format (if (memq ?n switches) + 'integer + 'string)) (file-alist - (directory-files-and-attributes dir nil wildcard-regexp t - (if (memq ?n switches) - 'integer - 'string))) + (catch 'new-list + (handler-bind + ((error + (lambda (error) + ;; `directory-files-and-attributes' signals + ;; failure on Unix systems if even a single + ;; file's attributes cannot be accessed. + ;; + ;; Detect errors signaled while retrieving file + ;; attributes and resolve them by creating the + ;; attribute list manually, ignoring the + ;; attributes of files that cannot be accessed + ;; in this sense. + (when (member (cadr error) + '("Getting attributes" + "Reading symbolic link")) + (let ((file-list (directory-files dir nil + wildcard-regexp + t))) + (throw 'new-list + (mapcar (lambda (file) + (cons file + (or (ignore-errors + (file-attributes + file id-format)) + nil))) + file-list))))))) + (directory-files-and-attributes + dir nil wildcard-regexp t id-format)))) (sum 0) (max-uid-len 0) (max-gid-len 0) @@ -845,6 +873,7 @@ The l switch is assumed to be always present and cannot be turned off." (let ((lsflags '(("-a" . "--all") ("-A" . "--almost-all") ("-B" . "--ignore-backups") + ("-c" . "--time=ctime") ("-C" . "--color") ("-F" . "--classify") ("-G" . "--no-group") @@ -855,7 +884,9 @@ The l switch is assumed to be always present and cannot be turned off." ("-r" . "--reverse") ("-R" . "--recursive") ("-s" . "--size") + ("-t" . "--sort=time") ("-S" . "--sort.*[ \\\t]") + ("-u" . "--time=atime") ("" . "--group-directories-first") ("" . "--author") ("" . "--escape") diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index ed21e777b28..98083c0489a 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -638,7 +638,7 @@ USER and PASSWORD should be non-nil." 235)) (cl-defmethod smtpmail-try-auth-method - (process (_mech (eql xoauth2)) user password) + (process (_mech (eql 'xoauth2)) user password) (smtpmail-command-or-throw process (concat "AUTH XOAUTH2 " diff --git a/lisp/master.el b/lisp/master.el index 0caf4d7963f..9151ca212d1 100644 --- a/lisp/master.el +++ b/lisp/master.el @@ -136,6 +136,8 @@ See `recenter'." (defun master-says (&optional command arg) "Display slave buffer and execute COMMAND with ARG in its window." (interactive) + (unless master-of + (error "Current buffer is not a master of any other buffer")) (if (null (buffer-live-p (get-buffer master-of))) (error "Slave buffer has disappeared") (let ((window (selected-window))) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 0a844c538b4..61395577035 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1363,7 +1363,7 @@ Moves point to the end of the new text." (setq newtext (substring newtext 0 (- suffix-len)))) (goto-char beg) (let ((length (- end beg))) ;Read `end' before we insert the text. - (insert-and-inherit newtext) + (insert-before-markers-and-inherit newtext) (delete-region (point) (+ (point) length))) (forward-char suffix-len))) @@ -2375,34 +2375,38 @@ This adds the face `completions-common-part' to the first It returns a list with font-lock properties applied to each element, and with BASE-SIZE appended as the last element." (when completions - (let ((com-str-len (- prefix-len (or base-size 0)))) - (nconc - (mapcar - (lambda (elem) - (let ((str - ;; Don't modify the string itself, but a copy, since the - ;; string may be read-only or used for other purposes. - ;; Furthermore, since `completions' may come from - ;; display-completion-list, `elem' may be a list. - (if (consp elem) - (car (setq elem (cons (copy-sequence (car elem)) - (cdr elem)))) - (setq elem (copy-sequence elem))))) - (font-lock-prepend-text-property - 0 - ;; If completion-boundaries returns incorrect - ;; values, all-completions may return strings - ;; that don't contain the prefix. - (min com-str-len (length str)) - 'face 'completions-common-part str) - (if (> (length str) com-str-len) - (font-lock-prepend-text-property com-str-len (1+ com-str-len) - 'face - 'completions-first-difference - str))) - elem) - completions) - base-size)))) + (let* ((com-str-len (- prefix-len (or base-size 0))) + (hilit-fn + (lambda (str) + (font-lock-prepend-text-property + 0 + ;; If completion-boundaries returns incorrect values, + ;; all-completions may return strings that don't contain + ;; the prefix. + (min com-str-len (length str)) + 'face 'completions-common-part str) + (when (> (length str) com-str-len) + (font-lock-prepend-text-property + com-str-len (1+ com-str-len) + 'face 'completions-first-difference str)) + str))) + (if completion-lazy-hilit + (setq completion-lazy-hilit-fn hilit-fn) + (setq completions + (mapcar + (lambda (elem) + ;; Don't modify the string itself, but a copy, since + ;; the string may be read-only or used for other + ;; purposes. Furthermore, since `completions' may come + ;; from display-completion-list, `elem' may be a list. + (funcall hilit-fn + (if (consp elem) + (car (setq elem (cons (copy-sequence (car elem)) + (cdr elem)))) + (setq elem (copy-sequence elem)))) + elem) + completions))) + (nconc completions base-size)))) (defun display-completion-list (completions &optional common-substring group-fun) "Display the list of completions, COMPLETIONS, using `standard-output'. @@ -2580,23 +2584,23 @@ The candidate will still be chosen by `choose-completion' unless (base-size (or (cdr last) 0)) (prefix (unless (zerop base-size) (substring string 0 base-size))) (minibuffer-completion-base (substring string 0 base-size)) - (base-prefix (buffer-substring (minibuffer--completion-prompt-end) - (+ start base-size))) - (base-suffix - (if (or (eq (alist-get 'category (cdr md)) 'file) - completion-in-region-mode-predicate) - (buffer-substring - (save-excursion - (if completion-in-region-mode-predicate - (point) - (or (search-forward "/" nil t) (point-max)))) - (point-max)) - "")) + (ctable minibuffer-completion-table) + (cpred minibuffer-completion-predicate) + (cprops completion-extra-properties) + (field-end + (save-excursion + (forward-char + (cdr (completion-boundaries (buffer-substring start (point)) + ctable + cpred + (buffer-substring (point) end)))) + (point-marker))) + (field-char (and (< field-end end) (char-after field-end))) (all-md (completion--metadata (buffer-substring-no-properties start (point)) base-size md - minibuffer-completion-table - minibuffer-completion-predicate)) + ctable + cpred)) (ann-fun (completion-metadata-get all-md 'annotation-function)) (aff-fun (completion-metadata-get all-md 'affixation-function)) (sort-fun (completion-metadata-get all-md 'display-sort-function)) @@ -2675,34 +2679,31 @@ The candidate will still be chosen by `choose-completion' unless (with-current-buffer standard-output (setq-local completion-base-position - (list (+ start base-size) - ;; FIXME: We should pay attention to completion - ;; boundaries here, but currently - ;; completion-all-completions does not give us the - ;; necessary information. - end)) - (setq-local completion-base-affixes - (list base-prefix base-suffix)) + (list (+ start base-size) field-end)) (setq-local completion-list-insert-choice-function - (let ((ctable minibuffer-completion-table) - (cpred minibuffer-completion-predicate) - (cprops completion-extra-properties)) (lambda (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)) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + (when (> (point) end) + ;; Completion suffix has changed, have to adapt. + (setq end (+ end + (cdr (completion-boundaries + (concat prefix choice) ctable cpred + (buffer-substring end (point)))))) + ;; Stopped before some field boundary. + (when (> (point) end) + (setq field-char (char-after end)))) + (when (and field-char + (= (aref choice (1- (length choice))) + field-char)) + (setq end (1+ end))) + ;; 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) @@ -2713,7 +2714,7 @@ The candidate will still be chosen by `choose-completion' unless ;; completion is not finished. (completion--done result (if (eq (car bounds) (length result)) - 'exact 'finished))))))) + 'exact 'finished)))))) (display-completion-list completions nil group-fun))))) nil))) @@ -3180,7 +3181,7 @@ and `RET' accepts the input typed into the minibuffer." t)) cmd)))) -(defun minibuffer-visible-completions-bind (binding) +(defun minibuffer-visible-completions--bind (binding) "Use BINDING when completions are visible. Return an item that is enabled only when a window displaying the *Completions* buffer exists." @@ -3190,12 +3191,12 @@ displaying the *Completions* buffer exists." (defvar-keymap minibuffer-visible-completions-map :doc "Local keymap for minibuffer input with visible completions." - "<left>" (minibuffer-visible-completions-bind #'minibuffer-previous-completion) - "<right>" (minibuffer-visible-completions-bind #'minibuffer-next-completion) - "<up>" (minibuffer-visible-completions-bind #'minibuffer-previous-line-completion) - "<down>" (minibuffer-visible-completions-bind #'minibuffer-next-line-completion) - "RET" (minibuffer-visible-completions-bind #'minibuffer-choose-completion-or-exit) - "C-g" (minibuffer-visible-completions-bind #'minibuffer-hide-completions)) + "<left>" (minibuffer-visible-completions--bind #'minibuffer-previous-completion) + "<right>" (minibuffer-visible-completions--bind #'minibuffer-next-completion) + "<up>" (minibuffer-visible-completions--bind #'minibuffer-previous-line-completion) + "<down>" (minibuffer-visible-completions--bind #'minibuffer-next-line-completion) + "RET" (minibuffer-visible-completions--bind #'minibuffer-choose-completion-or-exit) + "C-g" (minibuffer-visible-completions--bind #'minibuffer-hide-completions)) ;;; Completion tables. @@ -4861,8 +4862,7 @@ insert the selected completion candidate to the minibuffer." (next-line-completion (or n 1)) (next-completion (or n 1))) (when auto-choose - (let ((completion-use-base-affixes t) - (completion-auto-deselect nil)) + (let ((completion-auto-deselect nil)) (choose-completion nil t t)))))) (defun minibuffer-previous-completion (&optional n) @@ -4900,8 +4900,7 @@ If NO-QUIT is non-nil, insert the completion candidate 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)))) + (choose-completion nil no-exit no-quit))) (defun minibuffer-choose-completion-or-exit (&optional no-exit no-quit) "Choose the completion from the minibuffer or exit the minibuffer. diff --git a/lisp/mouse.el b/lisp/mouse.el index cef88dede8a..410e52b2ecb 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -133,6 +133,19 @@ or macOS)." :type 'boolean :version "29.1") +(defcustom mouse-wheel-buttons + '((4 . wheel-up) (5 . wheel-down) (6 . wheel-left) (7 . wheel-right)) + "How to remap mouse button numbers to wheel events. +This is an alist of (NUMBER . SYMBOL) used to remap old-style mouse wheel +events represented as mouse button events. It remaps mouse button +NUMBER to the event SYMBOL. SYMBOL must be one of `wheel-up', `wheel-down', +`wheel-left', or `wheel-right'. +This is used only for events that come from sources known to generate such +events, such as X11 events when XInput2 is not used, or events coming from +a text terminal." + :type '(alist) + :version "30.1") + (defvar mouse--last-down nil) (defun mouse--down-1-maybe-follows-link (&optional _prompt) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 66a1fa1a706..9fc922eebc9 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -56,20 +56,17 @@ (bound-and-true-p mouse-wheel-mode)) (mouse-wheel-mode 1))) -(defvar mouse-wheel-obey-old-style-wheel-buttons t - "If non-nil, treat mouse-4/5/6/7 events as mouse wheel events. -These are the event names used historically in X11 before XInput2. -They are sometimes generated by things like text-terminals as well.") +(make-obsolete-variable 'mouse-wheel-up-event 'mouse-wheel-buttons "30.1") +(make-obsolete-variable 'mouse-wheel-down-event 'mouse-wheel-buttons "30.1") +(make-obsolete-variable 'mouse-wheel-left-event 'mouse-wheel-buttons "30.1") +(make-obsolete-variable 'mouse-wheel-right-event 'mouse-wheel-buttons "30.1") -(defcustom mouse-wheel-down-event - (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-4) +(defcustom mouse-wheel-down-event 'mouse-4 "Event used for scrolling down, beside `wheel-up', if any." :group 'mouse :type 'symbol :set #'mouse-wheel-change-button) - -(defcustom mouse-wheel-up-event - (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-5) +(defcustom mouse-wheel-up-event 'mouse-5 "Event used for scrolling up, beside `wheel-down', if any." :group 'mouse :type 'symbol @@ -223,12 +220,10 @@ Also see `mouse-wheel-tilt-scroll'." (defvar mwheel-scroll-right-function 'scroll-right "Function that does the job of scrolling right.") -(defvar mouse-wheel-left-event - (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-6) +(defvar mouse-wheel-left-event 'mouse-6 "Event used for scrolling left, beside `wheel-left', if any.") -(defvar mouse-wheel-right-event - (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-7) +(defvar mouse-wheel-right-event 'mouse-7 "Event used for scrolling right, beside `wheel-right', if any.") (defun mouse-wheel--get-scroll-window (event) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 46f85daba24..dd5f0e88859 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -270,7 +270,7 @@ The result will be made available in `dbus-return-values-table'." (result (gethash key dbus-return-values-table))) (when (consp result) (setcar result :complete) - (setcdr result (if (= (length args) 1) (car args) args))))) + (setcdr result (if (length= args 1) (car args) args))))) (defun dbus-notice-synchronous-call-errors (ev er) "Detect errors resulting from pending synchronous calls." @@ -773,7 +773,7 @@ Example: ;; Signals are sent always with the unique name as sender. Note: ;; the unique name of `dbus-service-dbus' is that string itself. (if (and (stringp service) - (not (zerop (length service))) + (length> service 0) (not (string-equal service dbus-service-dbus)) (/= (string-to-char service) ?:)) (setq uname (dbus-get-name-owner bus service)) @@ -994,20 +994,26 @@ association to the service from D-Bus." (defun dbus-string-to-byte-array (string) "Transform STRING to list (:array :byte C1 :byte C2 ...). -STRING shall be UTF-8 coded." - (if (zerop (length string)) +The resulting byte array contains the raw bytes of the UTF-8 encoded +STRING." + (if (length= string 0) '(:array :signature "y") - (cons :array (mapcan (lambda (c) (list :byte c)) string)))) - -(defun dbus-byte-array-to-string (byte-array &optional multibyte) - "Transform BYTE-ARRAY into UTF-8 coded string. -BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte -array as produced by `dbus-string-to-byte-array'. The resulting -string is unibyte encoded, unless MULTIBYTE is non-nil." - (apply - (if multibyte #'string #'unibyte-string) - (unless (equal byte-array '(:array :signature "y")) - (seq-filter #'characterp byte-array)))) + (cons :array + (mapcan (lambda (c) (list :byte c)) + (let (last-coding-system-used) + (encode-coding-string string 'utf-8 'nocopy)))))) + +(defun dbus-byte-array-to-string (byte-array &optional _multibyte) + "Transform BYTE-ARRAY with UTF-8 byte sequence into a string. +BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as +produced by `dbus-string-to-byte-array', and the individual bytes must +be a valid UTF-8 byte sequence." + (declare (advertised-calling-convention (byte-array) "30.1")) + (if-let ((bytes (seq-filter #'characterp byte-array)) + (string (apply #'unibyte-string bytes))) + (let (last-coding-system-used) + (decode-coding-string string 'utf-8 'nocopy)) + "")) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -1026,7 +1032,7 @@ escaped to \"_\". Returns the escaped string. Algorithm taken from telepathy-glib's `tp_escape_as_identifier'." - (if (zerop (length string)) + (if (length= string 0) "_" (replace-regexp-in-string "\\`[0-9]\\|[^A-Za-z0-9]" diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index d4dfa33716c..313e825b4d8 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -105,7 +105,10 @@ This port is probably always 2628 so there should be no need to modify it." "*" "The dictionary which is used for searching definitions and matching. * and ! have a special meaning, * search all dictionaries, ! search until -one dictionary yields matches." +one dictionary yields matches. +Otherwise, the value should be a string, the name of the dictionary to use. +Dictionary names are generally specific to the servers, and are obtained +via `dictionary-dictionaries'." :group 'dictionary :type 'string :version "28.1") @@ -784,10 +787,10 @@ FUNCTION is the callback which is called for each search result." (defun dictionary-do-search (word dictionary function &optional nomatching) "Search for WORD in DICTIONARY and call FUNCTION for each result. -Optional argument NOMATCHING controls whether to suppress the display -of matching words." - - (insert (format-message "Searching for `%s' in `%s'\n" word dictionary)) +Optional argument NOMATCHING, if non-nil, means suppress the display +of the \"Searching\" report and of the matching words." + (unless nomatching + (insert (format-message "Searching for `%s' in `%s'\n" word dictionary))) (dictionary-send-command (concat "define " (dictionary-encode-charset dictionary "") " \"" @@ -1356,11 +1359,22 @@ prompt for DICTIONARY." (nconc minor-mode-alist '((dictionary-tooltip-mode " Dict"))) (defcustom dictionary-tooltip-dictionary - nil - "This dictionary to lookup words for tooltips." + t + "The dictionary to lookup words for `dictionary-tooltip-mode'. +If this is nil, `dictionary-tooltip-mode' is effectively disabled: no tooltips +will be shown. +If the value is t, `dictionary-tooltip-mode' will use the same dictionary as +specified by `dictionary-default-dictionary'. +Otherwise, the value should be a string, the name of a dictionary to use, and +can use the same special values * and ! as for `dictionary-default-dictionary', +with the same meanings. +Dictionary names are generally specific to the servers, and are obtained +via `dictionary-dictionaries'." :group 'dictionary - :type '(choice (const :tag "None" nil) string) - :version "28.1") + :type '(choice (const :tag "None (disables Dictionary tooltips)" nil) + (const :tag "Same as `dictionary-default-dictionary'" t) + string) + :version "30.1") (defun dictionary-definition (word &optional dictionary) (unwind-protect @@ -1377,14 +1391,20 @@ prompt for DICTIONARY." nil) (defun dictionary-word-at-mouse-event (event) - (with-current-buffer (tooltip-event-buffer event) - (let ((point (posn-point (event-end event)))) - (if (use-region-p) - (when (and (<= (region-beginning) point) (<= point (region-end))) - (buffer-substring (region-beginning) (region-end))) - (save-excursion - (goto-char point) - (current-word)))))) + (let ((buf (tooltip-event-buffer event))) + (when (bufferp buf) + (with-current-buffer buf + (let ((point (posn-point (event-end event)))) + ;; posn-point can return something other than buffer position when + ;; the mouse pointer is over the menu bar or tool bar or tab-bar. + (when (number-or-marker-p point) + (if (use-region-p) + (when (and (<= (region-beginning) point) + (<= point (region-end))) + (buffer-substring (region-beginning) (region-end))) + (save-excursion + (goto-char point) + (current-word))))))))) (defvar dictionary-tooltip-mouse-event nil "Event that triggered the tooltip mode.") @@ -1393,15 +1413,24 @@ prompt for DICTIONARY." "Search the current word in the `dictionary-tooltip-dictionary'." (interactive "e") (if (and dictionary-tooltip-mode dictionary-tooltip-dictionary) - (let ((word (dictionary-word-at-mouse-event dictionary-tooltip-mouse-event))) - (if word - (let ((definition - (dictionary-definition word dictionary-tooltip-dictionary))) - (if definition - (tooltip-show (dictionary-decode-charset definition - dictionary-tooltip-dictionary))))) - t) - nil)) + ;; This function runs from the tooltip timer. We don't want to + ;; signal errors from the timer due to "Unknown server answers", + ;; we prefer not to show anything in that case. FIXME: Perhaps + ;; use with-demoted-errors, to show the unknonw answers in the + ;; echo-area? + (ignore-errors + (let* ((word (dictionary-word-at-mouse-event + dictionary-tooltip-mouse-event)) + (dict (if (eq dictionary-tooltip-dictionary t) + dictionary-default-dictionary + dictionary-tooltip-dictionary))) + (if word + (let ((definition (dictionary-definition word dict))) + (if definition + (tooltip-show (dictionary-decode-charset + definition dict))))) + t) + nil))) (defun dictionary-tooltip-track-mouse (event) "Called whenever a dictionary tooltip display is about to be triggered." @@ -1443,6 +1472,11 @@ active it will overwrite that mode for the current buffer." (if on (local-set-key [mouse-movement] 'dictionary-tooltip-track-mouse) (local-set-key [mouse-movement] 'ignore)) + ;; Unconditionally ignore mouse-movement events on the tool bar and + ;; tab-bar, since these are unrelated to the current buffer. + ;; FIXME: This disables help-echo for tab-bar and tool-bar buttons. + (local-set-key [tool-bar mouse-movement] 'ignore) + (local-set-key [tab-bar mouse-movement] 'ignore) on)) ;;;###autoload @@ -1536,11 +1570,18 @@ Further arguments are currently ignored." nil t nil 'dictionary-word-history default t))) (defun dictionary-dictionaries () - "Return the list of dictionaries the server supports." + "Return the list of dictionaries the server supports. +The elements of the list have the form (NAME . DESCRIPTION), +where NAME is the string that identifies the dictionary for +the server, and DESCRIPTION is its more detailed description, +which usually includes the languages it supports." (dictionary-send-command "show db") (when (and (= (read (dictionary-read-reply)) 110)) (with-temp-buffer (insert (dictionary-read-answer)) + ;; We query the server using 'raw-text', so decode now to present + ;; human-readable names to the user. + (decode-coding-region (point-min) (point-max) 'utf-8) (goto-char (point-min)) (let ((result '(("!" . "First matching dictionary") ("*" . "All dictionaries")))) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 39ea964d47a..c3437ddd1d6 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1300,6 +1300,24 @@ This consults the entries in `eww-readable-urls' (which see)." map) "Tool bar for `eww-mode'.") +(declare-function set-text-conversion-style "textconv.c") + +(defun eww-check-text-conversion () + "Check if point is within a field and toggle text conversion. +Set `text-conversion-style' to the value `action' if it isn't +already and point is within the prompt field, or if +`text-conversion-style' is `nil', so as to guarantee that +the input method functions properly for the purpose of typing +within text input fields." + (when (and (eq major-mode 'eww-mode) + (fboundp 'set-text-conversion-style)) + (if (eq (car-safe (get-text-property (point) 'field)) + :eww-form) + (unless (eq text-conversion-style 'action) + (set-text-conversion-style 'action)) + (unless (not text-conversion-style) + (set-text-conversion-style nil))))) + ;; Autoload cookie needed by desktop.el. ;;;###autoload (define-derived-mode eww-mode special-mode "eww" @@ -1328,7 +1346,12 @@ This consults the entries in `eww-readable-urls' (which see)." (add-hook 'text-scale-mode-hook #'eww--rescale-images nil t) (setq-local outline-search-function 'shr-outline-search outline-level 'shr-outline-level) - (setq buffer-read-only t)) + (add-hook 'post-command-hook #'eww-check-text-conversion nil t) + (setq buffer-read-only t) + ;; Insertion at the first character of a field should inherit the + ;; field's face, form and field, not the previous character's. + (setq text-property-default-nonsticky '((face . t) (eww-form . t) + (field . t)))) (defvar text-scale-mode) (defvar text-scale-mode-amount) @@ -1487,16 +1510,19 @@ just re-display the HTML already fetched." (defvar-keymap eww-submit-map "RET" #'eww-submit - "C-c C-c" #'eww-submit) + "C-c C-c" #'eww-submit + "<mouse-2>" #'eww-submit) (defvar-keymap eww-submit-file "RET" #'eww-select-file - "C-c C-c" #'eww-submit) + "C-c C-c" #'eww-submit + "<mouse-2>" #'eww-select-file) (defvar-keymap eww-checkbox-map "SPC" #'eww-toggle-checkbox "RET" #'eww-toggle-checkbox - "C-c C-c" #'eww-submit) + "C-c C-c" #'eww-submit + "<mouse-2>" #'eww-toggle-checkbox) (defvar-keymap eww-text-map :full t :parent text-mode-map @@ -1585,6 +1611,8 @@ just re-display the HTML already fetched." :type "submit" :name (dom-attr dom 'name))) (put-text-property start (point) 'keymap eww-submit-map) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (insert " "))) (defun eww-form-checkbox (dom) @@ -1600,6 +1628,8 @@ just re-display the HTML already fetched." :checked (dom-attr dom 'checked) :name (dom-attr dom 'name))) (put-text-property start (point) 'keymap eww-checkbox-map) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (insert " "))) (defun eww-form-file (dom) @@ -1618,11 +1648,17 @@ just re-display the HTML already fetched." :type (downcase (dom-attr dom 'type)) :name (dom-attr dom 'name))) (put-text-property start (point) 'keymap eww-submit-file) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (insert " "))) -(defun eww-select-file () - "Change the value of the upload file menu under point." - (interactive nil eww-mode) +(defun eww-select-file (&optional event) + "Change the value of the upload file menu under point. +EVENT, if non-nil, is the mouse event that preceded this command. +Interactively, EVENT is the value of `last-nonmenu-event'." + (interactive (list last-nonmenu-event) eww-mode) + (when (and event (setq event (event-start event))) + (goto-char (posn-point event))) (let* ((input (get-text-property (point) 'eww-form))) (let ((filename (let ((insert-default-directory t)) @@ -1638,7 +1674,12 @@ just re-display the HTML already fetched." (readonly-property (if (or (dom-attr dom 'disabled) (dom-attr dom 'readonly)) 'read-only - 'inhibit-read-only))) + 'inhibit-read-only)) + form) + (setq form (list :eww-form eww-form + :value value + :type type + :name (dom-attr dom 'name))) (insert value) (when (< (length value) width) (insert (make-string (- width (length value)) ? ))) @@ -1646,11 +1687,9 @@ just re-display the HTML already fetched." (put-text-property start (point) 'inhibit-read-only t) (put-text-property start (point) 'local-map eww-text-map) (put-text-property start (point) readonly-property t) - (put-text-property start (point) 'eww-form - (list :eww-form eww-form - :value value - :type type - :name (dom-attr dom 'name))) + (put-text-property start (point) 'eww-form form) + (put-text-property start (point) 'field form) + (put-text-property start (point) 'front-sticky t) (insert " "))) (defconst eww-text-input-types '("text" "password" "textarea" @@ -1661,13 +1700,7 @@ just re-display the HTML already fetched." See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-process-text-input (beg end replace-length) - (when-let* ((pos (and (< (1+ end) (point-max)) - (> (1- end) (point-min)) - (cond - ((get-text-property (1+ end) 'eww-form) - (1+ end)) - ((get-text-property (1- end) 'eww-form) - (1- end)))))) + (when-let* ((pos (field-beginning (point)))) (let* ((form (get-text-property pos 'eww-form)) (properties (text-properties-at pos)) (buffer-undo-list t) @@ -1685,7 +1718,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (1- (line-end-position)) (eww-end-of-field))) (while (and (> length 0) - (eql (char-after (1- (point))) ? )) + (eq (char-after (1- (point))) ? )) (delete-region (1- (point)) (point)) (cl-decf length)))) ((< length 0) @@ -1709,6 +1742,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (when (string-match " +\\'" value) (setq value (substring value 0 (match-beginning 0)))) (plist-put form :value value) + (plist-put form :type type) (when (equal type "password") ;; Display passwords as asterisks. (let ((start (eww-beginning-of-field))) @@ -1721,7 +1755,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (value (or (dom-text dom) "")) (lines (string-to-number (or (dom-attr dom 'rows) "10"))) (width (string-to-number (or (dom-attr dom 'cols) "10"))) - end) + end form) (shr-ensure-newline) (insert value) (shr-ensure-newline) @@ -1741,11 +1775,13 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (put-text-property (line-beginning-position) (point) 'local-map eww-textarea-map) (forward-line 1)) - (put-text-property start (point) 'eww-form - (list :eww-form eww-form - :value value - :type "textarea" - :name (dom-attr dom 'name))) + (setq form (list :eww-form eww-form + :value value + :type "textarea" + :name (dom-attr dom 'name))) + (put-text-property start (point) 'eww-form form) + (put-text-property start (point) 'front-sticky t) + (put-text-property start (point) 'field form) (put-text-property start (1+ start) 'shr-tab-stop t))) (defun eww-tag-input (dom) @@ -1809,6 +1845,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (put-text-property start (point) 'eww-form menu) (add-face-text-property start (point) 'eww-form-select) (put-text-property start (point) 'keymap eww-select-map) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (unless (= start (point)) (put-text-property start (1+ start) 'help-echo "select field") (put-text-property start (1+ start) 'shr-tab-stop t)) @@ -1867,9 +1905,13 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (set-text-properties start new-end properties)) start)) -(defun eww-toggle-checkbox () - "Toggle the value of the checkbox under point." - (interactive nil eww-mode) +(defun eww-toggle-checkbox (&optional event) + "Toggle the value of the checkbox under point. +EVENT, if non-nil, is the mouse event that preceded this command. +Interactively, EVENT is the value of `last-nonmenu-event'." + (interactive (list last-nonmenu-event) eww-mode) + (when (and event (setq event (event-start event))) + (goto-char (posn-point event))) (let* ((input (get-text-property (point) 'eww-form)) (type (plist-get input :type))) (if (equal type "checkbox") @@ -1937,9 +1979,13 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (substring value 0 (match-beginning 0)) value))))) -(defun eww-submit () - "Submit the current form." - (interactive nil eww-mode) +(defun eww-submit (&optional event) + "Submit the form under point or EVENT. +EVENT, if non-nil, is the mouse event that preceded this command. +Interactively, EVENT is the value of `last-nonmenu-event'." + (interactive (list last-nonmenu-event) eww-mode) + (when (and event (setq event (event-start event))) + (goto-char (posn-point event))) (let* ((this-input (get-text-property (point) 'eww-form)) (form (plist-get this-input :eww-form)) values next-submit) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index b0c3dcb9a70..b5fb4d47d57 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -111,6 +111,10 @@ Security'." "/usr/local/share/certs/ca-root-nss.crt" ; FreeBSD "/etc/ssl/cert.pem" ; macOS, Dragora, Parabola "/etc/certs/ca-certificates.crt" ; OpenIndiana + "/system/etc/security/cacerts/*" ; Android system + "/system/etc/security/cacerts_supl/*" ; Android, supplementary + "/system/etc/security/cacerts_google/*" ; Android, Google + "/data/misc/user/0/cacerts-added/*" ; Android, user-specified (?) ) "List of CA bundle location filenames or a function returning said list. If a file path contains glob wildcards, they will be expanded. diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index ed6e00f578a..d720c4efe6b 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -42,7 +42,7 @@ (concat (sasl-client-name client) " " (encode-hex-string (hmac-md5 (sasl-step-data step) passphrase))) - (fillarray passphrase 0)))) + (clear-string passphrase)))) (put 'sasl-cram 'sasl-mechanism (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el index 75106fceee9..c8f38abb2aa 100644 --- a/lisp/net/sasl-digest.el +++ b/lisp/net/sasl-digest.el @@ -107,7 +107,7 @@ charset algorithm cipher-opts auth-param)." (concat "AUTHENTICATE:" digest-uri (if (member qop '("auth-int" "auth-conf")) ":00000000000000000000000000000000"))))))) - (fillarray passphrase 0)))) + (clear-string passphrase)))) (defun sasl-digest-md5-response (client step) (let* ((plist diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index 621b873af59..eb3d94475b9 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -219,7 +219,7 @@ It contain at least 64 bits of entropy." (not (string= authenticator-name name))) (concat authenticator-name "\0" name "\0" passphrase) (concat "\0" name "\0" passphrase)) - (fillarray passphrase 0)))) + (clear-string passphrase)))) (put 'sasl-plain 'sasl-mechanism (sasl-make-mechanism "PLAIN" sasl-plain-steps)) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 09df5f5a9bb..14b3f7aa163 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1510,7 +1510,8 @@ Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-infore (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case))) (setcar attr rep))) (dolist (child (dom-children dom)) - (shr-correct-dom-case child)) + (when (consp child) + (shr-correct-dom-case child))) dom) (defun shr-tag-svg (dom) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index da23d062c2e..b794d8b481a 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -222,15 +222,14 @@ arguments to pass to the OPERATION." ;;;###tramp-autoload (defun tramp-adb-parse-device-names (_ignore) "Return a list of (nil host) tuples allowed to access." - (delq nil - (mapcar - (lambda (line) - (when (string-match - (rx bol (group (+ (not blank))) (+ blank) "device" eol) line) - ;; Replace ":" by "#". - `(nil ,(tramp-compat-string-replace - ":" tramp-prefix-port-format (match-string 1 line))))) - (tramp-process-lines nil tramp-adb-program "devices")))) + (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (group (+ (not blank))) (+ blank) "device" eol) line) + ;; Replace ":" by "#". + `(nil ,(tramp-compat-string-replace + ":" tramp-prefix-port-format (match-string 1 line))))) + (tramp-process-lines nil tramp-adb-program "devices"))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el index 09bee323f5e..953f75ad9f3 100644 --- a/lisp/net/tramp-androidsu.el +++ b/lisp/net/tramp-androidsu.el @@ -63,7 +63,7 @@ may edit files belonging to any and all applications." "Directories in which to search for transfer programs and the like." :group 'tramp :version "30.1" - :type '(list string)) + :type '(repeat string)) (defvar tramp-androidsu-su-mm-supported 'unknown "Whether `su -mm' is supported on this system.") @@ -77,19 +77,27 @@ may edit files belonging to any and all applications." "Name of the local temporary directory on Android.") ;;;###tramp-autoload +(defun tramp-enable-androidsu-method () + "Enable \"androidsu\" method." + (add-to-list 'tramp-methods + `(,tramp-androidsu-method + (tramp-login-program "su") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell ,tramp-androidsu-local-shell-name) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-tmpdir ,tramp-androidsu-local-tmp-directory) + (tramp-connection-timeout 10) + (tramp-shell-name ,tramp-androidsu-local-shell-name))) + + (add-to-list 'tramp-default-user-alist + `(,(rx bos (literal tramp-androidsu-method) eos) + nil ,tramp-root-id-string))) + +;;;###tramp-autoload (tramp--with-startup - (add-to-list 'tramp-methods - `(,tramp-androidsu-method - (tramp-login-program "su") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-shell ,tramp-androidsu-local-shell-name) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-tmpdir ,tramp-androidsu-local-tmp-directory) - (tramp-connection-timeout 10) - (tramp-shell-name ,tramp-androidsu-local-shell-name))) - (add-to-list 'tramp-default-user-alist - `(,tramp-androidsu-method nil ,tramp-root-id-string))) + (when (eq system-type 'android) + (tramp-enable-androidsu-method))) (defvar android-use-exec-loader) ; androidfns.c. @@ -366,13 +374,19 @@ FUNCTION." ;; suitable options for specifying the mount namespace and ;; suchlike. (setq - p (make-process - :name name :buffer buffer - :command (if (tramp-get-connection-property v "remote-namespace") - (append (list "su" "-mm" "-" user "-c") command) - (append (list "su" "-" user "-c") command)) - :coding coding :noquery noquery :connection-type connection-type - :sentinel sentinel :stderr stderr)) + p (let ((android-use-exec-loader nil)) + (make-process + :name name + :buffer buffer + :command + (if (tramp-get-connection-property v "remote-namespace") + (append (list "su" "-mm" "-" user "-c") command) + (append (list "su" "-" user "-c") command)) + :coding coding + :noquery noquery + :connection-type connection-type + :sentinel sentinel + :stderr stderr))) ;; Set filter. Prior Emacs 29.1, it doesn't work reliably ;; to provide it as `make-process' argument when filter is ;; t. See Bug#51177. diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 225a26ad1cd..30c38d19fb7 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -540,13 +540,13 @@ PROPERTIES is a list of file properties (strings)." (defun tramp-list-connections () "Return all active `tramp-file-name' structs according to `tramp-cache-data'." (let ((tramp-verbose 0)) - (delq nil (mapcar - (lambda (key) - (and (tramp-file-name-p key) - (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer") - key)) - (hash-table-keys tramp-cache-data))))) + (tramp-compat-seq-keep + (lambda (key) + (and (tramp-file-name-p key) + (null (tramp-file-name-localname key)) + (tramp-connection-property-p key "process-buffer") + key)) + (hash-table-keys tramp-cache-data)))) (defun tramp-dump-connection-properties () "Write persistent connection properties into file \ diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index d3af7a009ec..f381c2e9ff0 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -691,25 +691,25 @@ This is needed if there are compatibility problems." (format "tramp (%s %s/%s)" ; package name and version tramp-version tramp-repository-branch tramp-repository-version) (sort - (delq nil (mapcar - (lambda (x) - (and x (boundp x) (not (get x 'tramp-suppress-trace)) - (cons x 'tramp-reporter-dump-variable))) - (append - (mapcar #'intern (all-completions "tramp-" obarray #'boundp)) - ;; Non-Tramp variables of interest. - '(shell-prompt-pattern - backup-by-copying - backup-by-copying-when-linked - backup-by-copying-when-mismatch - backup-by-copying-when-privileged-mismatch - backup-directory-alist - password-cache - password-cache-expiry - remote-file-name-inhibit-cache - connection-local-profile-alist - connection-local-criteria-alist - file-name-handler-alist)))) + (tramp-compat-seq-keep + (lambda (x) + (and x (boundp x) (not (get x 'tramp-suppress-trace)) + (cons x 'tramp-reporter-dump-variable))) + (append + (mapcar #'intern (all-completions "tramp-" obarray #'boundp)) + ;; Non-Tramp variables of interest. + '(shell-prompt-pattern + backup-by-copying + backup-by-copying-when-linked + backup-by-copying-when-mismatch + backup-by-copying-when-privileged-mismatch + backup-directory-alist + password-cache + password-cache-expiry + remote-file-name-inhibit-cache + connection-local-profile-alist + connection-local-criteria-alist + file-name-handler-alist))) (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y))))) 'tramp-load-report-modules ; pre-hook @@ -792,12 +792,10 @@ buffer in your bug report. ;; Dump buffer local variables. (insert "\nlocal variables:\n================") - (dolist (buffer - (delq nil - (mapcar - (lambda (b) - (when (string-match-p "\\*tramp/" (buffer-name b)) b)) - (buffer-list)))) + (dolist (buffer (tramp-compat-seq-keep + (lambda (b) + (when (string-match-p "\\*tramp/" (buffer-name b)) b)) + (buffer-list))) (let ((reporter-eval-buffer buffer) (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) (with-current-buffer elbuf diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 98de0dba7ff..d7492be63f2 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -294,6 +294,13 @@ Also see `ignore'." (autoload 'netrc-parse "netrc") (netrc-parse file)))) +;; Function `seq-keep' is new in Emacs 29.1. +(defalias 'tramp-compat-seq-keep + (if (fboundp 'seq-keep) + #'seq-keep + (lambda (function sequence) + (delq nil (seq-map function sequence))))) + ;; User option `password-colon-equivalents' is new in Emacs 30.1. (if (boundp 'password-colon-equivalents) (defvaralias diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el index 30639cbeb85..902fc6a451b 100644 --- a/lisp/net/tramp-container.el +++ b/lisp/net/tramp-container.el @@ -83,6 +83,15 @@ ;; Where: ;; SANDBOX is the running sandbox to connect to. ;; It could be an application ID, an instance ID, or a PID. +;; +;; +;; +;; Open a file on a running Apptainer instance: +;; +;; C-x C-f /apptainer:INSTANCE:/path/to/file +;; +;; Where: +;; INSTANCE is the running instance to connect to. ;;; Code: @@ -143,6 +152,14 @@ If it is nil, the default context will be used." (string))) ;;;###tramp-autoload +(defcustom tramp-apptainer-program "apptainer" + "Name of the Apptainer client program." + :group 'tramp + :version "30.1" + :type '(choice (const "apptainer") + (string))) + +;;;###tramp-autoload (defconst tramp-docker-method "docker" "Tramp method name to use to connect to Docker containers.") @@ -173,6 +190,10 @@ This is for out-of-band connections.") "Tramp method name to use to connect to Flatpak sandboxes.") ;;;###tramp-autoload +(defconst tramp-apptainer-method "apptainer" + "Tramp method name to use to connect to Apptainer instances.") + +;;;###tramp-autoload (defmacro tramp-skeleton-completion-function (method &rest body) "Skeleton for `tramp-*-completion-function' with multi-hop support. BODY is the backend specific code." @@ -209,7 +230,7 @@ see its function help for a description of the format." (concat program " ps --format '{{.ID}}\t{{.Names}}'"))) (lines (split-string raw-list "\n" 'omit)) (names - (mapcar + (tramp-compat-seq-keep (lambda (line) (when (string-match (rx bol (group (1+ nonl)) @@ -217,7 +238,7 @@ see its function help for a description of the format." line) (or (match-string 2 line) (match-string 1 line)))) lines))) - (mapcar (lambda (name) (list nil name)) (delq nil names))))) + (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload (defun tramp-kubernetes--completion-function (method) @@ -339,7 +360,7 @@ see its function help for a description of the format." (when-let ((raw-list (shell-command-to-string (concat program " list -c"))) ;; Ignore header line. (lines (cdr (split-string raw-list "\n" 'omit))) - (names (mapcar + (names (tramp-compat-seq-keep (lambda (line) (when (string-match (rx bol (1+ (not space)) @@ -347,7 +368,7 @@ see its function help for a description of the format." line) (match-string 1 line))) lines))) - (mapcar (lambda (name) (list nil name)) (delq nil names))))) + (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload (defun tramp-flatpak--completion-function (method) @@ -363,7 +384,7 @@ see its function help for a description of the format." ;; Ignore header line. (concat program " ps --columns=instance,application | cat -"))) (lines (split-string raw-list "\n" 'omit)) - (names (mapcar + (names (tramp-compat-seq-keep (lambda (line) (when (string-match (rx bol (* space) (group (+ (not space))) @@ -371,7 +392,29 @@ see its function help for a description of the format." line) (or (match-string 2 line) (match-string 1 line)))) lines))) - (mapcar (lambda (name) (list nil name)) (delq nil names))))) + (mapcar (lambda (name) (list nil name)) names)))) + +;;;###tramp-autoload +(defun tramp-apptainer--completion-function (method) + "List Apptainer instances available for connection. + +This function is used by `tramp-set-completion-function', please +see its function help for a description of the format." + (tramp-skeleton-completion-function method + (when-let ((raw-list + (shell-command-to-string (concat program " instance list"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (group (1+ (not space))) + (1+ space) (1+ (not space)) + (1+ space) (1+ (not space))) + line) + (match-string 1 line))) + lines))) + (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload (defvar tramp-default-remote-shell) ;; Silence byte compiler. @@ -453,29 +496,9 @@ see its function help for a description of the format." (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-i" "-c")))) - (add-to-list 'tramp-methods - `(,tramp-toolbox-method - (tramp-login-program ,tramp-toolbox-program) - (tramp-login-args (("run") - ("-c" "%h") - ("%l"))) - (tramp-direct-async (,tramp-default-remote-shell "-c")) - (tramp-remote-shell ,tramp-default-remote-shell) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) - - (add-to-list 'tramp-default-host-alist `(,tramp-toolbox-method nil "")) - - (add-to-list 'tramp-methods - `(,tramp-flatpak-method - (tramp-login-program ,tramp-flatpak-program) - (tramp-login-args (("enter") - ("%h") - ("%l"))) - (tramp-direct-async (,tramp-default-remote-shell "-c")) - (tramp-remote-shell ,tramp-default-remote-shell) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-completion-multi-hop-methods tramp-docker-method) + (add-to-list 'tramp-completion-multi-hop-methods tramp-podman-method) + (add-to-list 'tramp-completion-multi-hop-methods tramp-kubernetes-method) (tramp-set-completion-function tramp-docker-method @@ -495,53 +518,99 @@ see its function help for a description of the format." (tramp-set-completion-function tramp-kubernetes-method - `((tramp-kubernetes--completion-function ,tramp-kubernetes-method))) + `((tramp-kubernetes--completion-function ,tramp-kubernetes-method)))) - (tramp-set-completion-function - tramp-toolbox-method - `((tramp-toolbox--completion-function ,tramp-toolbox-method))) +;;;###tramp-autoload +(defun tramp-enable-toolbox-method () + "Enable connection to Toolbox containers." + (add-to-list 'tramp-methods + `(,tramp-toolbox-method + (tramp-login-program ,tramp-toolbox-program) + (tramp-login-args (("run") + ("-c" "%h") + ("%l"))) + (tramp-direct-async (,tramp-default-remote-shell "-c")) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-default-host-alist `(,tramp-toolbox-method nil "")) + (add-to-list 'tramp-completion-multi-hop-methods tramp-toolbox-method) + + (tramp-set-completion-function + tramp-toolbox-method + `((tramp-toolbox--completion-function ,tramp-toolbox-method)))) - (tramp-set-completion-function - tramp-flatpak-method - `((tramp-flatpak--completion-function ,tramp-flatpak-method))) +;;;###tramp-autoload +(defun tramp-enable-flatpak-method () + "Enable connection to Flatpak sandboxes." + (add-to-list 'tramp-methods + `(,tramp-flatpak-method + (tramp-login-program ,tramp-flatpak-program) + (tramp-login-args (("enter") + ("%h") + ("%l"))) + (tramp-direct-async (,tramp-default-remote-shell "-c")) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-completion-multi-hop-methods tramp-flatpak-method) + + (tramp-set-completion-function + tramp-flatpak-method + `((tramp-flatpak--completion-function ,tramp-flatpak-method)))) - (add-to-list 'tramp-completion-multi-hop-methods tramp-docker-method) - (add-to-list 'tramp-completion-multi-hop-methods tramp-podman-method) - (add-to-list 'tramp-completion-multi-hop-methods tramp-kubernetes-method) - (add-to-list 'tramp-completion-multi-hop-methods tramp-toolbox-method) - (add-to-list 'tramp-completion-multi-hop-methods tramp-flatpak-method) - - ;; Default connection-local variables for Tramp. - - (defconst tramp-kubernetes-connection-local-default-variables - '((tramp-config-check . tramp-kubernetes--current-context-data) - ;; This variable will be eval'ed in `tramp-expand-args'. - (tramp-extra-expand-args - . (?a (tramp-kubernetes--container (car tramp-current-connection)) - ?h (tramp-kubernetes--pod (car tramp-current-connection)) - ?x (tramp-kubernetes--context-namespace - (car tramp-current-connection))))) - "Default connection-local variables for remote kubernetes connections.") - - (connection-local-set-profile-variables - 'tramp-kubernetes-connection-local-default-profile - tramp-kubernetes-connection-local-default-variables) - - (connection-local-set-profiles - `(:application tramp :protocol ,tramp-kubernetes-method) - 'tramp-kubernetes-connection-local-default-profile) - - (defconst tramp-flatpak-connection-local-default-variables - `((tramp-remote-path . ,(cons "/app/bin" tramp-remote-path))) - "Default connection-local variables for remote flatpak connections.") - - (connection-local-set-profile-variables - 'tramp-flatpak-connection-local-default-profile - tramp-flatpak-connection-local-default-variables) - - (connection-local-set-profiles - `(:application tramp :protocol ,tramp-flatpak-method) - 'tramp-flatpak-connection-local-default-profile)) +;;;###tramp-autoload +(defun tramp-enable-apptainer-method () + "Enable connection to Apptainer instances." + (add-to-list 'tramp-methods + `(,tramp-apptainer-method + (tramp-login-program ,tramp-apptainer-program) + (tramp-login-args (("shell") + ("instance://%h") + ("%h"))) ; Needed for multi-hop check. + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-completion-multi-hop-methods tramp-apptainer-method) + + (tramp-set-completion-function + tramp-apptainer-method + `((tramp-apptainer--completion-function ,tramp-apptainer-method)))) + +;; Default connection-local variables for Tramp. + +(defconst tramp-kubernetes-connection-local-default-variables + '((tramp-config-check . tramp-kubernetes--current-context-data) + ;; This variable will be eval'ed in `tramp-expand-args'. + (tramp-extra-expand-args + . (?a (tramp-kubernetes--container (car tramp-current-connection)) + ?h (tramp-kubernetes--pod (car tramp-current-connection)) + ?x (tramp-kubernetes--context-namespace + (car tramp-current-connection))))) + "Default connection-local variables for remote kubernetes connections.") + +(connection-local-set-profile-variables + 'tramp-kubernetes-connection-local-default-profile + tramp-kubernetes-connection-local-default-variables) + +(connection-local-set-profiles + `(:application tramp :protocol ,tramp-kubernetes-method) + 'tramp-kubernetes-connection-local-default-profile) + +(defconst tramp-flatpak-connection-local-default-variables + `((tramp-remote-path . ,(cons "/app/bin" tramp-remote-path))) + "Default connection-local variables for remote flatpak connections.") + +(connection-local-set-profile-variables + 'tramp-flatpak-connection-local-default-profile + tramp-flatpak-connection-local-default-variables) + +(connection-local-set-profiles + `(:application tramp :protocol ,tramp-flatpak-method) + 'tramp-flatpak-connection-local-default-profile) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index ced3c1b5aa8..03b0dedbb70 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -189,12 +189,11 @@ arguments to pass to the OPERATION." (defun tramp-rclone-parse-device-names (_ignore) "Return a list of (nil host) tuples allowed to access." (with-tramp-connection-property nil "rclone-device-names" - (delq nil - (mapcar - (lambda (line) - (when (string-match (rx bol (group (+ (not blank))) ":" eol) line) - `(nil ,(match-string 1 line)))) - (tramp-process-lines nil tramp-rclone-program "listremotes"))))) + (tramp-compat-seq-keep + (lambda (line) + (when (string-match (rx bol (group (+ (not blank))) ":" eol) line) + `(nil ,(match-string 1 line)))) + (tramp-process-lines nil tramp-rclone-program "listremotes")))) ;; File name primitives. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 66e648624b2..408e1611632 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -273,22 +273,6 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) (add-to-list 'tramp-methods - `("nc" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p") ("%n"))) - (tramp-remote-shell ,tramp-default-remote-shell) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "nc") - ;; We use "-v" for better error tracking. - (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) - (tramp-copy-file-name (("%f"))) - (tramp-remote-copy-program "nc") - ;; We use "-p" as required for newer busyboxes. For older - ;; busybox/nc versions, the value must be (("-l") ("%r")). This - ;; can be achieved by tweaking `tramp-connection-properties'. - (tramp-remote-copy-args (("-l") ("-p" "%r") ("%n"))))) - (add-to-list 'tramp-methods `("su" (tramp-login-program "su") (tramp-login-args (("-") ("%u"))) @@ -329,21 +313,6 @@ The string is used in `tramp-methods'.") (tramp-session-timeout 300) (tramp-password-previous-hop t))) (add-to-list 'tramp-methods - `("ksu" - (tramp-login-program "ksu") - (tramp-login-args (("%u") ("-q"))) - (tramp-remote-shell ,tramp-default-remote-shell) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) - (add-to-list 'tramp-methods - `("krlogin" - (tramp-login-program "krlogin") - (tramp-login-args (("%h") ("-l" "%u") ("-x"))) - (tramp-remote-shell ,tramp-default-remote-shell) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) - (add-to-list 'tramp-methods `("plink" (tramp-login-program "plink") (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") @@ -403,30 +372,18 @@ The string is used in `tramp-methods'.") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k"))) (tramp-copy-keep-date t))) - (add-to-list 'tramp-methods - `("fcp" - (tramp-login-program "fsh") - (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) - (tramp-remote-shell ,tramp-default-remote-shell) - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-i") ("-c")) - (tramp-copy-program "fcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t))) (add-to-list 'tramp-default-method-alist `(,tramp-local-host-regexp ,(rx bos (literal tramp-root-id-string) eos) "su")) (add-to-list 'tramp-default-user-alist - `(,(rx bos (| "su" "sudo" "doas" "ksu") eos) + `(,(rx bos (| "su" "sudo" "doas") eos) nil ,tramp-root-id-string)) ;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. ;; Do not add "plink" based methods, they ask interactively for the user. (add-to-list 'tramp-default-user-alist - `(,(rx bos - (| "rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp") - eos) + `(,(rx bos (| "rcp" "remcp" "rsh" "telnet") eos) nil ,(user-login-name)))) (defconst tramp-default-copy-file-name '(("%u" "@") ("%h" ":") ("%f")) @@ -508,20 +465,94 @@ The string is used in `tramp-methods'.") (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) (tramp-set-completion-function "telnet" tramp-completion-function-alist-telnet) - (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) (tramp-set-completion-function "su" tramp-completion-function-alist-su) (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) (tramp-set-completion-function "doas" tramp-completion-function-alist-su) - (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) (tramp-set-completion-function "sg" tramp-completion-function-alist-sg) - (tramp-set-completion-function - "krlogin" tramp-completion-function-alist-rsh) (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) (tramp-set-completion-function "plinkx" tramp-completion-function-alist-putty) (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)) + (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh)) + +;;;###tramp-autoload +(defun tramp-enable-nc-method () + "Enable \"ksu\" method." + (add-to-list 'tramp-methods + `("nc" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p") ("%n"))) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "nc") + ;; We use "-v" for better error tracking. + (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) + (tramp-copy-file-name (("%f"))) + (tramp-remote-copy-program "nc") + ;; We use "-p" as required for newer busyboxes. For + ;; older busybox/nc versions, the value must be + ;; (("-l") ("%r")). This can be achieved by tweaking + ;; `tramp-connection-properties'. + (tramp-remote-copy-args (("-l") ("-p" "%r") ("%n"))))) + + (add-to-list 'tramp-default-user-alist + `(,(rx bos "nc" eos) nil ,(user-login-name))) + + (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet)) + +;;;###tramp-autoload +(defun tramp-enable-ksu-method () + "Enable \"ksu\" method." + (add-to-list 'tramp-methods + `("ksu" + (tramp-login-program "ksu") + (tramp-login-args (("%u") ("-q"))) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + + (add-to-list 'tramp-default-user-alist + `(,(rx bos "ksu" eos) nil ,tramp-root-id-string)) + + (tramp-set-completion-function "ksu" tramp-completion-function-alist-su)) + +;;;###tramp-autoload +(defun tramp-enable-krlogin-method () + "Enable \"krlogin\" method." + (add-to-list 'tramp-methods + `("krlogin" + (tramp-login-program "krlogin") + (tramp-login-args (("%h") ("-l" "%u") ("-x"))) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-default-user-alist + `(,(rx bos "krlogin" eos) nil ,(user-login-name))) + + (tramp-set-completion-function + "krlogin" tramp-completion-function-alist-rsh)) + +;;;###tramp-autoload +(defun tramp-enable-fcp-method () + "Enable \"fcp\" method." + (add-to-list 'tramp-methods + `("fcp" + (tramp-login-program "fsh") + (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-i") ("-c")) + (tramp-copy-program "fcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) + + (add-to-list 'tramp-default-user-alist + `(,(rx bos "fcp" eos) nil ,(user-login-name))) + + (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)) (defcustom tramp-sh-extra-args `((,(rx (| bos "/") "bash" eos) . "-noediting -norc -noprofile") @@ -2653,6 +2684,18 @@ The method used must be an out-of-band method." (let ((dired (tramp-get-ls-command-with v "--dired"))) (when (stringp switches) (setq switches (split-string switches))) + ;; Newer coreutil versions of ls (9.5 and up) imply long format + ;; output when "--dired" is given. Suppress this implicit rule. + (when dired + (let ((tem switches) + case-fold-search) + (catch 'long + (while tem + (when (and (not (string-match-p "--" (car tem))) + (string-match-p "l" (car tem))) + (throw 'long nil)) + (setq tem (cdr tem))) + (setq dired nil)))) (setq switches (append switches (split-string (tramp-sh--quoting-style-options v)) (when dired `(,dired)))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 5b101000926..f92a7ff14d4 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1460,6 +1460,35 @@ calling HANDLER.") ;;; Internal functions which must come first: +(defun tramp-enable-method (method) + "Enable optional METHOD if possible." + (interactive + (list + (completing-read + "method: " + (tramp-compat-seq-keep + (lambda (x) + (when-let ((name (symbol-name x)) + ;; It must match `tramp-enable-METHOD-method'. + ((string-match + (rx "tramp-enable-" + (group (regexp tramp-method-regexp)) + "-method") + name)) + (method (match-string 1 name)) + ;; It must not be enabled yet. + ((not (assoc method tramp-methods)))) + method)) + ;; All method enabling functions. + (mapcar + #'intern (all-completions "tramp-enable-" obarray #'functionp)))))) + + (when-let (((not (assoc method tramp-methods))) + (fn (intern (format "tramp-enable-%s-method" method))) + ((functionp fn))) + (funcall fn) + (message "Tramp method \"%s\" enabled" method))) + ;; Conversion functions between external representation and ;; internal data structure. Convenience functions for internal ;; data structure. @@ -3533,6 +3562,11 @@ on the same host. Otherwise, TARGET is quoted." ,@body))) +(defcustom tramp-inhibit-errors-if-setting-file-attributes-fail nil + "Whether to warn only if `tramp-*-set-file-{modes,times,uid-gid}' fails." + :version "30.1" + :type 'boolean) + (defmacro tramp-skeleton-set-file-modes-times-uid-gid (filename &rest body) "Skeleton for `tramp-*-set-file-{modes,times,uid-gid}'. @@ -3548,7 +3582,11 @@ BODY is the backend specific code." ;; "file-writable-p". '("file-directory-p" "file-exists-p" "file-symlinkp" "file-truename") (tramp-flush-file-properties v localname)) - ,@body)) + (condition-case err + (progn ,@body) + (error (if tramp-inhibit-errors-if-setting-file-attributes-fail + (display-warning 'tramp (error-message-string err)) + (signal (car err) (cdr err))))))) (defmacro tramp-skeleton-write-region (start end filename append visit lockname mustbenew &rest body) @@ -4536,7 +4574,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (rx bos (group (+ nonl)) "@" (group (+ nonl)) "." (group (+ digit)) - (? ":" (+ digit)) eos) + (? ":" (? "-") (+ digit)) eos) "The format of a lock file.") (defun tramp-handle-file-locked-p (file) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index c131d39c110..41647d42cc5 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -105,7 +105,7 @@ ("2.3.5.26.3" . "26.3") ("2.4.3.27.1" . "27.1") ("2.4.5.27.2" . "27.2") ("2.5.2.28.1" . "28.1") ("2.5.3.28.2" . "28.2") ("2.5.4" . "28.3") - ("2.6.0.29.1" . "29.1") ("2.6.2.29.2" . "29.2"))) + ("2.6.0.29.1" . "29.1") ("2.6.2.29.2" . "29.2") ("2.6.3-pre" . "29.3"))) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 4bf912e54c0..20c7f3fe596 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -501,8 +501,8 @@ Otherwise, redisplay will reset the window's vscroll." ;;;###autoload (defun pixel-scroll-precision-scroll-down-page (delta) "Scroll the current window down by DELTA pixels. -Note that this function doesn't work if DELTA is larger than -the height of the current window." +Note that this function doesn't work if DELTA is larger than or +equal to the height of the current window." (let* ((desired-pos (posn-at-x-y 0 (+ delta (window-tab-line-height) (window-header-line-height)))) @@ -551,8 +551,7 @@ the height of the current window." (defun pixel-scroll-precision-scroll-down (delta) "Scroll the current window down by DELTA pixels." - (let ((max-height (- (window-text-height nil t) - (frame-char-height)))) + (let ((max-height (1- (window-text-height nil t)))) (while (> delta max-height) (pixel-scroll-precision-scroll-down-page max-height) (setq delta (- delta max-height))) @@ -666,8 +665,7 @@ to `pixel-scroll-precision-interpolation-factor'." (defun pixel-scroll-precision-scroll-up (delta) "Scroll the current window up by DELTA pixels." - (let ((max-height (- (window-text-height nil t) - (frame-char-height)))) + (let ((max-height (window-text-height nil t))) (when (> max-height 0) (while (> delta max-height) (pixel-scroll-precision-scroll-up-page max-height) diff --git a/lisp/profiler.el b/lisp/profiler.el index 4e02cd1d890..eb72f128c07 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -275,10 +275,7 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." (define-hash-table-test 'profiler-function-equal #'function-equal - (lambda (f) (cond - ((byte-code-function-p f) (aref f 1)) - ((eq (car-safe f) 'closure) (cddr f)) - (t f)))) + (lambda (f) (if (closurep f) (aref f 1) f))) (defun profiler-calltree-build-unified (tree log) ;; Let's try to unify all those partial backtraces into a single diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index e48bcc64f14..b1520db22e9 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -123,9 +123,16 @@ ARG is passed to `fill-paragraph'." (let ((node (treesit-node-at (point)))) (when (string-match-p c-ts-common--comment-regexp (treesit-node-type node)) - (if (save-excursion - (goto-char (treesit-node-start node)) - (looking-at "//")) + (if (or (save-excursion + (goto-char (treesit-node-start node)) + (looking-at "//")) + ;; In rust, NODE will be the body of a comment, and the + ;; parent will be the whole comment. + (if-let ((start (treesit-node-start + (treesit-node-parent node)))) + (save-excursion + (goto-char start) + (looking-at "//")))) (fill-comment-paragraph arg) (c-ts-common--fill-block-comment arg))) ;; Return t so `fill-paragraph' doesn't attempt to fill by @@ -221,7 +228,9 @@ Set up: - `adaptive-fill-first-line-regexp' - `paragraph-start' - `paragraph-separate' - - `fill-paragraph-function'" + - `fill-paragraph-function' + - `comment-line-break-function' + - `comment-multi-line'" (setq-local comment-start "// ") (setq-local comment-end "") (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) @@ -267,7 +276,66 @@ Set up: eol) "\f"))) (setq-local paragraph-separate paragraph-start) - (setq-local fill-paragraph-function #'c-ts-common--fill-paragraph)) + (setq-local fill-paragraph-function #'c-ts-common--fill-paragraph) + + (setq-local comment-line-break-function + #'c-ts-common-comment-indent-new-line) + (setq-local comment-multi-line t)) + +(defun c-ts-common-comment-indent-new-line (&optional soft) + "Break line at point and indent, continuing comment if within one. + +This is like `comment-indent-new-line', but specialized for C-style // +and /* */ comments. SOFT works the same as in +`comment-indent-new-line'." + ;; I want to experiment with explicitly listing out all each cases and + ;; handle them separately, as opposed to fiddling with `comment-start' + ;; and friends. This will have more duplicate code and will be less + ;; generic, but in the same time might save us from writting cryptic + ;; code to handle all sorts of edge cases. + ;; + ;; For this command, let's try to make it basic: if the current line + ;; is a // comment, insert a newline and a // prefix; if the current + ;; line is in a /* comment, insert a newline and a * prefix. No + ;; auto-fill or other smart features. + (cond + ;; Line starts with //, or ///, or ////... + ;; Or //! (used in rust). + ((save-excursion + (beginning-of-line) + (looking-at (rx "//" (group (* (any "/!")) (* " "))))) + (let ((whitespaces (match-string 1))) + (if soft (insert-and-inherit ?\n) (newline 1)) + (delete-region (line-beginning-position) (point)) + (insert "//" whitespaces))) + + ;; Line starts with /* or /**. + ((save-excursion + (beginning-of-line) + (looking-at (rx "/*" (group (? "*") (* " "))))) + (let ((whitespace-and-star-len (length (match-string 1)))) + (if soft (insert-and-inherit ?\n) (newline 1)) + (delete-region (line-beginning-position) (point)) + (insert " *" (make-string whitespace-and-star-len ?\s)))) + + ;; Line starts with *. + ((save-excursion + (beginning-of-line) + (looking-at (rx (group (* " ") (any "*|") (* " "))))) + (let ((prefix (match-string 1))) + (if soft (insert-and-inherit ?\n) (newline 1)) + (delete-region (line-beginning-position) (point)) + (insert prefix))) + + ;; Line starts with whitespaces or no space. This is basically the + ;; default case since (rx (* " ")) matches anything. + ((save-excursion + (beginning-of-line) + (looking-at (rx (* " ")))) + (let ((whitespaces (match-string 0))) + (if soft (insert-and-inherit ?\n) (newline 1)) + (delete-region (line-beginning-position) (point)) + (insert whitespaces))))) ;;; Statement indent diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 3a89f0f494b..b703999d788 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -597,8 +597,9 @@ MODE is either `c' or `cpp'." (treesit-font-lock-rules :language mode :feature 'comment - `((comment) @font-lock-comment-face - (comment) @contextual) + `(((comment) @font-lock-doc-face + (:match ,(rx bos "/**") @font-lock-doc-face)) + (comment) @font-lock-comment-face) :language mode :feature 'preprocessor @@ -616,8 +617,11 @@ MODE is either `c' or `cpp'." (preproc_params (identifier) @font-lock-variable-name-face) - (preproc_defined) @font-lock-preprocessor-face - (preproc_defined (identifier) @font-lock-variable-name-face) + (preproc_defined + "defined" @font-lock-preprocessor-face + "(" @font-lock-preprocessor-face + (identifier) @font-lock-variable-name-face + ")" @font-lock-preprocessor-face) [,@c-ts-mode--preproc-keywords] @font-lock-preprocessor-face) :language mode @@ -661,7 +665,9 @@ MODE is either `c' or `cpp'." (qualified_identifier scope: (namespace_identifier) @font-lock-type-face) - (operator_cast) type: (type_identifier) @font-lock-type-face)) + (operator_cast) type: (type_identifier) @font-lock-type-face + + (namespace_identifier) @font-lock-constant-face)) [,@c-ts-mode--type-keywords] @font-lock-type-face) :language mode @@ -1207,7 +1213,9 @@ BEG and END are described in `treesit-range-rules'." "struct_specifier" "enum_specifier" "union_specifier" - "class_specifier" + ;; Make sure this doesn't match + ;; storage_class_specifier. + "^class_specifier$" "namespace_definition" "preproc_def" "preproc_function_def") diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 8c505e9556a..0b50844732f 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -7146,7 +7146,7 @@ comment at the start of cc-engine.el for more info." ;; FIXME!!! This routine ignores the possibility of macros entirely. ;; 2010-01-29. - (when (> end beg) + (when (or old-len (> end beg)) ;; Extend the region (BEG END) to deal with any complicating literals. (let* ((lit-search-beg (if (memq (char-before beg) '(?/ ?*)) (1- beg) beg)) @@ -7220,7 +7220,8 @@ comment at the start of cc-engine.el for more info." (c-put-char-properties beg end 'syntax-table '(1)) ;; If an open string's opener has just been neutralized, ;; do the same to the terminating LF. - (when (and end-literal-end + (when (and (> end beg) + end-literal-end (eq (char-before end-literal-end) ?\n) (equal (c-get-char-property (1- end-literal-end) 'syntax-table) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 1a9d0907bd0..5f11622733f 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -2463,7 +2463,7 @@ with // and /*, not more generic line and block comments." (backward-char) (setq pseudo (c-cheap-inside-bracelist-p (c-parse-state))))))) (goto-char pseudo)) - t) + (or pseudo (> (point) bod-lim))) ;; Move forward to the start of the next declaration. (progn (c-forward-syntactic-ws) ;; Have we got stuck in a comment at EOB? diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 11d400e145a..b18eb81fee1 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -2644,24 +2644,26 @@ and runs `compilation-filter-hook'." (text-properties-at (1- beg)))) (insert string) ;; If we exceeded the limit, hide the last portion of the line. - (when (> (current-column) width) - (let ((start (save-excursion - (move-to-column width) - (point)))) - (buttonize-region - start (point) - (lambda (start) - (let ((inhibit-read-only t)) - (remove-text-properties start (save-excursion - (goto-char start) - (line-end-position)) - (text-properties-at start))))) - (put-text-property - start (if (= (aref string (1- (length string))) ?\n) - ;; Don't hide the final newline. - (1- (point)) - (point)) - 'display (if (char-displayable-p ?…) "[…]" "[...]")))))) + (let* ((ends-in-nl (= (aref string (1- (length string))) ?\n)) + (curcol (if ends-in-nl + (progn (backward-char) (current-column)) + (current-column)))) + (when (> curcol width) + (let ((start (save-excursion + (move-to-column width) + (point)))) + (buttonize-region + start (point) + (lambda (start) + (let ((inhibit-read-only t)) + (remove-text-properties start (save-excursion + (goto-char start) + (line-end-position)) + (text-properties-at start))))) + (put-text-property + start (point) + 'display (if (char-displayable-p ?…) "[…]" "[...]")))) + (if ends-in-nl (forward-char))))) (defsubst compilation-buffer-internal-p () "Test if inside a compilation buffer." diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 9782eb443f2..29325ab9632 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -500,7 +500,15 @@ compilation and evaluation time conflicts." ;; Also, deal with the possible end of line obscured by a ;; trailing comment. (goto-char (c-point 'iopl)) - (looking-at "^[^//]*new[^//]*;$"))) + (when (looking-at-p ".*new.*") + (if (re-search-forward ";" (pos-eol) t 1) + ;; If the ';' is inside a comment, the statement hasn't + ;; likely ended, so we should accept as object init. + ;; Example: + ;; var x = new // This should return true ; + ;; var x = new(); // This should return false ; + (nth 4 (syntax-ppss (point))) + t)))) ;; Line should not already be terminated (save-excursion (goto-char (c-point 'eopl)) @@ -681,7 +689,9 @@ compilation and evaluation time conflicts." ((parent-is "binary_expression") parent 0) ((parent-is "block") parent-bol csharp-ts-mode-indent-offset) ((parent-is "local_function_statement") parent-bol 0) - ((parent-is "if_statement") parent-bol 0) + ((match "block" "if_statement") parent-bol 0) + ((match "else" "if_statement") parent-bol 0) + ((parent-is "if_statement") parent-bol csharp-ts-mode-indent-offset) ((parent-is "for_statement") parent-bol 0) ((parent-is "for_each_statement") parent-bol 0) ((parent-is "while_statement") parent-bol 0) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 7d2f1a55165..57a019e126d 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -7,7 +7,7 @@ ;; Maintainer: João Távora <joaotavora@gmail.com> ;; URL: https://github.com/joaotavora/eglot ;; Keywords: convenience, languages -;; Package-Requires: ((emacs "26.3") (jsonrpc "1.0.24") (flymake "1.2.1") (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") (seq "2.23") (external-completion "0.1")) +;; Package-Requires: ((emacs "26.3") (compat "27.1") (eldoc "1.14.0") (external-completion "0.1") (flymake "1.2.1") (jsonrpc "1.0.24") (project "0.9.8") (seq "2.23") (track-changes "1.2") (xref "1.6.2")) ;; This is a GNU ELPA :core package. Avoid adding functionality ;; that is not available in the version of Emacs recorded above or any @@ -103,13 +103,13 @@ (require 'pcase) (require 'compile) ; for some faces (require 'warnings) -(eval-when-compile - (require 'subr-x)) (require 'filenotify) (require 'ert) (require 'text-property-search nil t) (require 'diff-mode) (require 'diff) +(require 'track-changes) +(require 'compat) ;; These dependencies are also GNU ELPA core packages. Because of ;; bug#62576, since there is a risk that M-x package-install, despite @@ -133,6 +133,10 @@ ;; the loaded file is not the one that should have been loaded. (mapc reload '(project flymake xref jsonrpc external-completion)))) +;; Keep the eval-when-compile requires at the end, in case it's already been +;; required unconditionally by some earlier `require'. +(eval-when-compile (require 'subr-x)) + ;; forward-declare, but don't require (Emacs 28 doesn't seem to care) (defvar markdown-fontify-code-blocks-natively) (defvar company-backends) @@ -189,8 +193,8 @@ path of the PROGRAM that was chosen (interactively or automatically)." (lambda (&optional interactive _project) ;; JT@2021-06-13: This function is way more complicated than it - ;; could be because it accounts for the fact that - ;; `eglot--executable-find' may take much longer to execute on + ;; could be because it accounts for the fact that Compat's + ;; `executable-find' may take much longer to execute on ;; remote files. (let* ((listified (cl-loop for a in alternatives collect (if (listp a) a (list a)))) @@ -202,7 +206,7 @@ automatically)." nil) (interactive (let* ((augmented (mapcar (lambda (a) - (let ((found (eglot--executable-find + (let ((found (compat-call executable-find (car a) t))) (and found (cons (car a) (cons found (cdr a)))))) @@ -222,7 +226,7 @@ automatically)." nil)))) (t (cl-loop for (p . args) in listified - for probe = (eglot--executable-find p t) + for probe = (compat-call executable-find p t) when probe return (cons probe args) finally (funcall err))))))) @@ -241,7 +245,7 @@ automatically)." '("pylsp" "pyls" ("basedpyright-langserver" "--stdio") ("pyright-langserver" "--stdio") "jedi-language-server" "ruff-lsp"))) - ((js-json-mode json-mode json-ts-mode) + ((js-json-mode json-mode json-ts-mode jsonc-mode) . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") ("vscode-json-languageserver" "--stdio") ("json-languageserver" "--stdio")))) @@ -301,6 +305,7 @@ automatically)." (futhark-mode . ("futhark" "lsp")) ((lua-mode lua-ts-mode) . ,(eglot-alternatives '("lua-language-server" "lua-lsp"))) + (yang-mode . ("yang-language-server")) (zig-mode . ("zls")) ((css-mode css-ts-mode) . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio") @@ -516,7 +521,10 @@ ACTION is the default value for commands not in the alist." (defcustom eglot-report-progress t "If non-nil, show progress of long running LSP server work. If set to `messages', use *Messages* buffer, else use Eglot's -mode line indicator." +mode line indicator. + +For changes on this variable to take effect, you need to restart +the LSP connection. That can be done by `eglot-reconnect'." :type '(choice (const :tag "Don't show progress" nil) (const :tag "Show progress in *Messages*" messages) (const :tag "Show progress in Eglot's mode line indicator" t)) @@ -559,13 +567,6 @@ This can be useful when using docker to run a language server.") ;;; Constants ;;; -(defconst eglot--version - (eval-when-compile - (when byte-compile-current-file - (require 'lisp-mnt) - (lm-version byte-compile-current-file))) - "The version as a string of this version of Eglot. -It is nil if Eglot is not byte-complied.") (defconst eglot--symbol-kind-names `((1 . "File") (2 . "Module") @@ -595,11 +596,6 @@ It is nil if Eglot is not byte-complied.") (defconst eglot--{} (make-hash-table :size 0) "The empty JSON object.") -(defun eglot--executable-find (command &optional remote) - "Like Emacs 27's `executable-find', ignore REMOTE on Emacs 26." - (if (>= emacs-major-version 27) (executable-find command remote) - (executable-find command))) - (defun eglot--accepted-formats () (if (and (not eglot-prefer-plaintext) (fboundp 'gfm-view-mode)) ["markdown" "plaintext"] ["plaintext"])) @@ -1004,7 +1000,7 @@ ACTION is an LSP object of either `CodeAction' or `Command' type." [,@(mapcar #'car eglot--tag-faces)]))) :window `(:showDocument (:support t) - :workDoneProgress t) + :workDoneProgress ,(if eglot-report-progress t :json-false)) :general (list :positionEncodings ["utf-32" "utf-8" "utf-16"]) :experimental eglot--{}))) @@ -1064,7 +1060,7 @@ ACTION is an LSP object of either `CodeAction' or `Command' type." (declare-function w32-long-file-name "w32proc.c" (fn)) (defun eglot-uri-to-path (uri) - "Convert URI to file path, helped by `eglot--current-server'." + "Convert URI to file path, helped by `eglot-current-server'." (when (keywordp uri) (setq uri (substring (symbol-name uri) 1))) (let* ((server (eglot-current-server)) (remote-prefix (and server (eglot--trampish-p server))) @@ -1083,15 +1079,21 @@ ACTION is an LSP object of either `CodeAction' or `Command' type." (concat remote-prefix normalized)) uri))) -(defun eglot-path-to-uri (path) - "Convert PATH, a file name, to LSP URI string and return it." - (let ((truepath (file-truename path))) +(cl-defun eglot-path-to-uri (path &key truenamep) + "Convert PATH, a file name, to LSP URI string and return it. +TRUENAMEP indicated PATH is already a truename." + ;; LSP servers should not be expected to access the filesystem, and + ;; therefore are generally oblivious that some filenames are + ;; different, but point to the same file, like a symlink and its + ;; target. Make sure we hand the server the true name of a file by + ;; calling file-truename. + (let ((truepath (if truenamep path (file-truename path)))) (if (and (url-type (url-generic-parse-url path)) - ;; It might be MS Windows path which includes a drive - ;; letter that looks like a URL scheme (bug#59338) + ;; PATH might be MS Windows file name which includes a + ;; drive letter that looks like a URL scheme (bug#59338). (not (and (eq system-type 'windows-nt) (file-name-absolute-p truepath)))) - ;; Path is already a URI, so forward it to the LSP server + ;; PATH is already a URI, so forward it to the LSP server ;; untouched. The server should be able to handle it, since ;; it provided this URI to clients in the first place. path @@ -1313,7 +1315,7 @@ be guessed." main-mode base-prompt)) ((and program (not (file-name-absolute-p program)) - (not (eglot--executable-find program t))) + (not (compat-call executable-find program t))) (if full-program-invocation (concat (format "[eglot] I guess you want to run `%s'" full-program-invocation) @@ -1599,8 +1601,10 @@ This docstring appeases checkdoc, that's all." 'network)) (emacs-pid)) :clientInfo - `(:name "Eglot" ,@(when eglot--version - `(:version ,eglot--version))) + (append + '(:name "Eglot") + (let ((v (package-get-version))) + (and v (list :version v)))) ;; Maybe turn trampy `/ssh:foo@bar:/path/to/baz.py' ;; into `/path/to/baz.py', so LSP groks it. :rootPath (file-local-name @@ -1732,6 +1736,9 @@ return value is fed through the corresponding inverse function "Calculate number of UTF-16 code units from position given by LBP. LBP defaults to `eglot--bol'." (/ (- (length (encode-coding-region (or lbp (eglot--bol)) + ;; FIXME: How could `point' ever be + ;; larger than `point-max' (sounds like + ;; a bug in Emacs). ;; Fix github#860 (min (point) (point-max)) 'utf-16 t)) 2) @@ -1749,6 +1756,24 @@ LBP defaults to `eglot--bol'." :character (progn (when pos (goto-char pos)) (funcall eglot-current-linepos-function))))) +(defun eglot--virtual-pos-to-lsp-position (pos string) + "Return the LSP position at the end of STRING if it were inserted at POS." + (eglot--widening + (goto-char pos) + (forward-line 0) + ;; LSP line is zero-origin; Emacs is one-origin. + (let ((posline (1- (line-number-at-pos nil t))) + (linebeg (buffer-substring (point) pos)) + (colfun eglot-current-linepos-function)) + ;; Use a temp buffer because: + ;; - I don't know of a fast way to count newlines in a string. + ;; - We currently don't have `eglot-current-linepos-function' for strings. + (with-temp-buffer + (insert linebeg string) + (goto-char (point-max)) + (list :line (+ posline (1- (line-number-at-pos nil t))) + :character (funcall colfun)))))) + (defvar eglot-move-to-linepos-function #'eglot-move-to-utf-16-linepos "Function to move to a position within a line reported by the LSP server. @@ -1849,10 +1874,9 @@ Doubles as an indicator of snippet support." (font-lock-ensure) (goto-char (point-min)) (let ((inhibit-read-only t)) - (when (fboundp 'text-property-search-forward) ;; FIXME: use compat - (while (setq match (text-property-search-forward 'invisible)) - (delete-region (prop-match-beginning match) - (prop-match-end match))))) + (while (setq match (text-property-search-forward 'invisible)) + (delete-region (prop-match-beginning match) + (prop-match-end match)))) (string-trim (buffer-string)))))) (defun eglot--read-server (prompt &optional dont-if-just-the-one) @@ -1946,9 +1970,11 @@ For example, to keep your Company customization, add the symbol "A hook run by Eglot after it started/stopped managing a buffer. Use `eglot-managed-p' to determine if current buffer is managed.") +(defvar-local eglot--track-changes nil) + (define-minor-mode eglot--managed-mode "Mode for source buffers managed by some Eglot project." - :init-value nil :lighter nil :keymap eglot-mode-map + :init-value nil :lighter nil :keymap eglot-mode-map :interactive nil (cond (eglot--managed-mode (pcase (plist-get (eglot--capabilities (eglot-current-server)) @@ -1959,8 +1985,10 @@ Use `eglot-managed-p' to determine if current buffer is managed.") ("utf-8" (eglot--setq-saving eglot-current-linepos-function #'eglot-utf-8-linepos) (eglot--setq-saving eglot-move-to-linepos-function #'eglot-move-to-utf-8-linepos))) - (add-hook 'after-change-functions #'eglot--after-change nil t) - (add-hook 'before-change-functions #'eglot--before-change nil t) + (unless eglot--track-changes + (setq eglot--track-changes + (track-changes-register + #'eglot--track-changes-signal :disjoint t))) (add-hook 'kill-buffer-hook #'eglot--managed-mode-off nil t) ;; Prepend "didClose" to the hook after the "nonoff", so it will run first (add-hook 'kill-buffer-hook #'eglot--signal-textDocument/didClose nil t) @@ -1994,8 +2022,9 @@ Use `eglot-managed-p' to determine if current buffer is managed.") (eldoc-mode 1)) (cl-pushnew (current-buffer) (eglot--managed-buffers (eglot-current-server)))) (t - (remove-hook 'after-change-functions #'eglot--after-change t) - (remove-hook 'before-change-functions #'eglot--before-change t) + (when eglot--track-changes + (track-changes-unregister eglot--track-changes) + (setq eglot--track-changes nil)) (remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t) (remove-hook 'kill-buffer-hook #'eglot--signal-textDocument/didClose t) (remove-hook 'before-revert-hook #'eglot--signal-textDocument/didClose t) @@ -2345,8 +2374,14 @@ still unanswered LSP requests to the server\n"))) (lambda () (remhash token (eglot--progress-reporters server)))))))))) +(defvar-local eglot--TextDocumentIdentifier-cache nil + "LSP TextDocumentIdentifier-related cached info for current buffer. +Value is (TRUENAME . (:uri STR)), where STR is what is sent to the +server on textDocument/didOpen and similar calls. TRUENAME is the +expensive cached value of `file-truename'.") + (cl-defmethod eglot-handle-notification - (_server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics + (server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics &allow-other-keys) ; FIXME: doesn't respect `eglot-strict-mode' "Handle notification publishDiagnostics." (cl-flet ((eglot--diag-type (sev) @@ -2355,9 +2390,17 @@ still unanswered LSP requests to the server\n"))) ((= sev 2) 'eglot-warning) (t 'eglot-note))) (mess (source code message) - (concat source (and code (format " [%s]" code)) ": " message))) + (concat source (and code (format " [%s]" code)) ": " message)) + (find-it (abspath) + ;; `find-buffer-visiting' would be natural, but calls the + ;; potentially slow `file-truename' (bug#70036). + (cl-loop for b in (eglot--managed-buffers server) + when (with-current-buffer b + (equal (car eglot--TextDocumentIdentifier-cache) + abspath)) + return b))) (if-let* ((path (expand-file-name (eglot-uri-to-path uri))) - (buffer (find-buffer-visiting path))) + (buffer (find-it path))) (with-current-buffer buffer (cl-loop initially @@ -2483,11 +2526,16 @@ THINGS are either registrations or unregisterations (sic)." `(:success ,success))) (defun eglot--TextDocumentIdentifier () - "Compute TextDocumentIdentifier object for current buffer." - `(:uri ,(eglot-path-to-uri (or buffer-file-name - (ignore-errors - (buffer-file-name - (buffer-base-buffer))))))) + "Compute TextDocumentIdentifier object for current buffer. +Sets `eglot--TextDocumentIdentifier-uri' (which see) as a side effect." + (unless eglot--TextDocumentIdentifier-cache + (let ((truename (file-truename (or buffer-file-name + (ignore-errors + (buffer-file-name + (buffer-base-buffer))))))) + (setq eglot--TextDocumentIdentifier-cache + `(,truename . (:uri ,(eglot-path-to-uri truename :truenamep t)))))) + (cdr eglot--TextDocumentIdentifier-cache)) (defvar-local eglot--versioned-identifier 0) @@ -2556,7 +2604,7 @@ buffer." `(:triggerKind 2 :triggerCharacter ,trigger) `(:triggerKind 1))))) (defvar-local eglot--recent-changes nil - "Recent buffer changes as collected by `eglot--before-change'.") + "Recent buffer changes as collected by `eglot--track-changes-fetch'.") (cl-defmethod jsonrpc-connection-ready-p ((_server eglot-lsp-server) _what) "Tell if SERVER is ready for WHAT in current buffer." @@ -2564,63 +2612,59 @@ buffer." (defvar-local eglot--change-idle-timer nil "Idle timer for didChange signals.") -(defun eglot--before-change (beg end) - "Hook onto `before-change-functions' with BEG and END." - (when (listp eglot--recent-changes) - ;; Records BEG and END, crucially convert them into LSP - ;; (line/char) positions before that information is lost (because - ;; the after-change thingy doesn't know if newlines were - ;; deleted/added). Also record markers of BEG and END - ;; (github#259) - (push `(,(eglot--pos-to-lsp-position beg) - ,(eglot--pos-to-lsp-position end) - (,beg . ,(copy-marker beg nil)) - (,end . ,(copy-marker end t))) - eglot--recent-changes))) - (defvar eglot--document-changed-hook '(eglot--signal-textDocument/didChange) "Internal hook for doing things when the document changes.") -(defun eglot--after-change (beg end pre-change-length) - "Hook onto `after-change-functions'. -Records BEG, END and PRE-CHANGE-LENGTH locally." - (cl-incf eglot--versioned-identifier) - (pcase (car-safe eglot--recent-changes) - (`(,lsp-beg ,lsp-end - (,b-beg . ,b-beg-marker) - (,b-end . ,b-end-marker)) - ;; github#259 and github#367: with `capitalize-word' & friends, - ;; `before-change-functions' records the whole word's `b-beg' and - ;; `b-end'. Similarly, when `fill-paragraph' coalesces two - ;; lines, `b-beg' and `b-end' mark end of first line and end of - ;; second line, resp. In both situations, `beg' and `end' - ;; received here seemingly contradict that: they will differ by 1 - ;; and encompass the capitalized character or, in the coalescing - ;; case, the replacement of the newline with a space. We keep - ;; both markers and positions to detect and correct this. In - ;; this specific case, we ignore `beg', `len' and - ;; `pre-change-len' and send richer information about the region - ;; from the markers. I've also experimented with doing this - ;; unconditionally but it seems to break when newlines are added. - (if (and (= b-end b-end-marker) (= b-beg b-beg-marker) - (or (/= beg b-beg) (/= end b-end))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,(- b-end-marker b-beg-marker) - ,(buffer-substring-no-properties b-beg-marker - b-end-marker))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,pre-change-length - ,(buffer-substring-no-properties beg end))))) - (_ (setf eglot--recent-changes :emacs-messup))) +(defun eglot--track-changes-fetch (id) + (if (eq eglot--recent-changes :pending) (setq eglot--recent-changes nil)) + (track-changes-fetch + id (lambda (beg end before) + (cl-incf eglot--versioned-identifier) + (cond + ((eq eglot--recent-changes :emacs-messup) nil) + ((eq before 'error) (setf eglot--recent-changes :emacs-messup)) + (t (push `(,(eglot--pos-to-lsp-position beg) + ,(eglot--virtual-pos-to-lsp-position beg before) + ,(length before) + ,(buffer-substring-no-properties beg end)) + eglot--recent-changes)))))) + +(defun eglot--add-one-shot-hook (hook function &optional append local) + "Like `add-hook' but calls FUNCTION only once." + (let* ((fname (make-symbol (format "eglot--%s-once" function))) + (fun (lambda (&rest args) + (remove-hook hook fname local) + (apply function args)))) + (fset fname fun) + (add-hook hook fname append local))) + +(defun eglot--track-changes-signal (id &optional distance) + (cond + (distance + ;; When distance is <100, we may as well coalesce the changes. + (when (> distance 100) (eglot--track-changes-fetch id))) + (eglot--recent-changes nil) + ;; Note that there are pending changes, for the benefit of those + ;; who check it as a boolean. + (t (setq eglot--recent-changes :pending))) (when eglot--change-idle-timer (cancel-timer eglot--change-idle-timer)) - (let ((buf (current-buffer))) - (setq eglot--change-idle-timer - (run-with-idle-timer - eglot-send-changes-idle-time - nil (lambda () (eglot--when-live-buffer buf - (when eglot--managed-mode - (run-hooks 'eglot--document-changed-hook) - (setq eglot--change-idle-timer nil)))))))) + (setq eglot--change-idle-timer + (run-with-idle-timer + eglot-send-changes-idle-time nil + (lambda (buf) + (eglot--when-live-buffer buf + (when eglot--managed-mode + (if (track-changes-inconsistent-state-p) + ;; Not a good time (e.g. in the middle of Quail thingy, + ;; bug#70541): reschedule for the next idle period. + (eglot--add-one-shot-hook + 'post-command-hook + (lambda () + (eglot--when-live-buffer buf + (eglot--track-changes-signal id)))) + (run-hooks 'eglot--document-changed-hook) + (setq eglot--change-idle-timer nil))))) + (current-buffer)))) (defvar-local eglot-workspace-configuration () "Configure LSP servers specifically for a given project. @@ -2724,6 +2768,7 @@ When called interactively, use the currently active server" (defun eglot--signal-textDocument/didChange () "Send textDocument/didChange to server." + (eglot--track-changes-fetch eglot--track-changes) (when eglot--recent-changes (let* ((server (eglot--current-server-or-lose)) (sync-capability (eglot-server-capable :textDocumentSync)) @@ -2741,12 +2786,6 @@ When called interactively, use the currently active server" (buffer-substring-no-properties (point-min) (point-max))))) (cl-loop for (beg end len text) in (reverse eglot--recent-changes) - ;; github#259: `capitalize-word' and commands based - ;; on `casify_region' will cause multiple duplicate - ;; empty entries in `eglot--before-change' calls - ;; without an `eglot--after-change' reciprocal. - ;; Weed them out here. - when (numberp len) vconcat `[,(list :range `(:start ,beg :end ,end) :rangeLength len :text text)])))) (setq eglot--recent-changes nil) @@ -2754,7 +2793,9 @@ When called interactively, use the currently active server" (defun eglot--signal-textDocument/didOpen () "Send textDocument/didOpen to server." - (setq eglot--recent-changes nil eglot--versioned-identifier 0) + (setq eglot--recent-changes nil + eglot--versioned-identifier 0 + eglot--TextDocumentIdentifier-cache nil) (jsonrpc-notify (eglot--current-server-or-lose) :textDocument/didOpen `(:textDocument ,(eglot--TextDocumentItem)))) @@ -3869,6 +3910,7 @@ If NOERROR, return predicate, else erroring function." (define-derived-mode eglot-list-connections-mode tabulated-list-mode "" "Eglot mode for listing server connections \\{eglot-list-connections-mode-map}" + :interactive nil (setq-local tabulated-list-format `[("Language server" 16) ("Project name" 16) ("Modes handled" 16)]) (tabulated-list-init-header)) @@ -4058,6 +4100,27 @@ If NOERROR, return predicate, else erroring function." "https://debbugs.gnu.org/%s") (match-string 3)))) +;; Add command-mode property manually for compatibility with Emacs < 28. +(dolist (sym '(eglot-clear-status + eglot-code-action-inline + eglot-code-action-organize-imports + eglot-code-action-quickfix + eglot-code-action-rewrite + eglot-code-action-rewrite + eglot-code-actions + eglot-find-declaration + eglot-find-implementation + eglot-find-typeDefinition + eglot-forget-pending-continuations + eglot-format + eglot-format-buffer + eglot-inlay-hints-mode + eglot-reconnect + eglot-rename + eglot-signal-didChangeConfiguration + eglot-stderr-buffer)) + (function-put sym 'command-modes '(eglot--managed-mode))) + (provide 'eglot) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 8a713bd19a2..84814c9eaac 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -40,9 +40,10 @@ It has `lisp-mode-abbrev-table' as its parent." (defvar emacs-lisp-mode-syntax-table (let ((table (make-syntax-table lisp-data-mode-syntax-table))) - ;; These are redundant, now. - ;;(modify-syntax-entry ?\[ "(] " table) - ;;(modify-syntax-entry ?\] ")[ " table) + ;; Remove the "p" flag from the entry of `@' because we use instead + ;; `syntax-propertize' to take care of `,@', which is more precise. + ;; FIXME: We should maybe do the same in other Lisp modes? (bug#24542) + (modify-syntax-entry ?@ "_" table) table) "Syntax table used in `emacs-lisp-mode'.") @@ -2151,8 +2152,13 @@ Calls REPORT-FN directly." (point-max))) collect (flymake-make-diagnostic (current-buffer) - (if (= beg end) (1- beg) beg) - end + (if (= beg end) + (max (1- beg) (point-min)) + beg) + (if (= beg end) + (min (max beg (1+ (point-min))) + (point-max)) + end) level string))))))) @@ -2169,6 +2175,8 @@ directory of the buffer being compiled, and nothing else.") (dolist (path x t) (unless (stringp path) (throw 'tag nil))))))) +(defvar bytecomp--inhibit-lexical-cookie-warning) + ;;;###autoload (defun elisp-flymake-byte-compile (report-fn &rest _args) "A Flymake backend for elisp byte compilation. @@ -2184,7 +2192,13 @@ current buffer state and calls REPORT-FN when done." (save-restriction (widen) (write-region (point-min) (point-max) temp-file nil 'nomessage)) - (let* ((output-buffer (generate-new-buffer " *elisp-flymake-byte-compile*"))) + (let* ((output-buffer (generate-new-buffer " *elisp-flymake-byte-compile*")) + ;; Hack: suppress warning about missing lexical cookie in + ;; *scratch* buffers. + (warning-suppression-opt + (and (derived-mode-p 'lisp-interaction-mode) + '("--eval" + "(setq bytecomp--inhibit-lexical-cookie-warning t)")))) (setq elisp-flymake--byte-compile-process (make-process @@ -2196,6 +2210,7 @@ current buffer state and calls REPORT-FN when done." ;; "--eval" "(setq load-prefer-newer t)" ; for testing ,@(mapcan (lambda (path) (list "-L" path)) elisp-flymake-byte-compile-load-path) + ,@warning-suppression-opt "-f" "elisp-flymake--batch-compile-for-flymake" ,temp-file) :connection-type 'pipe diff --git a/lisp/progmodes/etags-regen.el b/lisp/progmodes/etags-regen.el index 6cd78d3577a..02d666ceff7 100644 --- a/lisp/progmodes/etags-regen.el +++ b/lisp/progmodes/etags-regen.el @@ -279,7 +279,7 @@ File extensions to generate the tags for." " ") ;; ctags's etags requires '-L' for stdin input. (if ctags-p "-L" "") - tags-file))) + (shell-quote-argument tags-file)))) (with-temp-buffer (mapc (lambda (f) (insert f "\n")) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 779c612f479..2e602658ea7 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -180,6 +180,59 @@ See `flymake-error-bitmap' and `flymake-warning-bitmap'." (const right-fringe) (const :tag "No fringe indicators" nil))) +(defcustom flymake-indicator-type (if (display-graphic-p) + 'fringes + 'margins) + "Indicate which indicator type to use for display errors. + +The value can be nil (don't indicate errors but just highlight them), +fringes (use fringes) or margins (use margins) + +Difference between fringes and margin is that fringes support diplaying +bitmaps on graphical displays and margins display text in a blank area +from current buffer that works in both graphical and text displays. + +See Info node `Fringes' and Info node `(elisp)Display Margins'." + :version "30.1" + :type '(choice (const :tag "Use Fringes" fringes) + (const :tag "Use Margins "margins) + (const :tag "No indicators" nil))) + +(defcustom flymake-margin-indicators-string + '((error "!!" compilation-error) + (warning "!" compilation-warning) + (note "!" compilation-info)) + "Strings used for margins indicators. +The value of each list may be a list of 3 elements where specifies the +error type, the string to use and its face, +or a list of 2 elements specifying only the error type and +the corresponding string. + +The option `flymake-margin-indicator-position' controls how and where +this is used." + :version "30.1" + :type '(repeat :tag "Error types lists" + (list :tag "String and face for error types" + (symbol :tag "Error type") + (string :tag "String") + (face :tag "Face")))) + +(defcustom flymake-autoresize-margins t + "If non-nil, automatically resize margin-width calling flymake--resize-margins. + +Only relevant if `flymake-indicator-type' is set to margins." + :version "30.1" + :type 'boolean) + +(defcustom flymake-margin-indicator-position 'left-margin + "The position to put Flymake margin indicator. +The value can be nil (do not use indicators), `left-margin' or `right-margin'. +See `flymake-margin-indicators-string'." + :version "30.1" + :type '(choice (const left-margin) + (const right-margin) + (const :tag "No margin indicators" nil))) + (make-obsolete-variable 'flymake-start-syntax-check-on-newline "can check on newline in post-self-insert-hook" "27.1") @@ -258,6 +311,11 @@ If set to nil, don't suppress any zero counters." (defvar-local flymake-check-start-time nil "Time at which syntax check was started.") +(defvar-local flymake--original-margin-width nil + "Store original margin width. +Used by `flymake--resize-margins' for restoring original margin width +when flymake is turned off.") + (defun flymake--log-1 (level sublog msg &rest args) "Do actual work for `flymake-log'." (let (;; never popup the log buffer @@ -630,6 +688,7 @@ Node `(Flymake)Flymake error types'" (put 'flymake-error 'face 'flymake-error) (put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap) +(put 'flymake-error 'flymake-margin-string (alist-get 'error flymake-margin-indicators-string)) (put 'flymake-error 'severity (warning-numeric-level :error)) (put 'flymake-error 'mode-line-face 'flymake-error-echo) (put 'flymake-error 'echo-face 'flymake-error-echo) @@ -638,6 +697,7 @@ Node `(Flymake)Flymake error types'" (put 'flymake-warning 'face 'flymake-warning) (put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap) +(put 'flymake-warning 'flymake-margin-string (alist-get 'warning flymake-margin-indicators-string)) (put 'flymake-warning 'severity (warning-numeric-level :warning)) (put 'flymake-warning 'mode-line-face 'flymake-warning-echo) (put 'flymake-warning 'echo-face 'flymake-warning-echo) @@ -646,6 +706,7 @@ Node `(Flymake)Flymake error types'" (put 'flymake-note 'face 'flymake-note) (put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap) +(put 'flymake-note 'flymake-margin-string (alist-get 'note flymake-margin-indicators-string)) (put 'flymake-note 'severity (warning-numeric-level :debug)) (put 'flymake-note 'mode-line-face 'flymake-note-echo) (put 'flymake-note 'echo-face 'flymake-note-echo) @@ -682,19 +743,55 @@ associated `flymake-category' return DEFAULT." (flymake--lookup-type-property type 'severity (warning-numeric-level :error))) -(defun flymake--fringe-overlay-spec (bitmap &optional recursed) - (if (and (symbolp bitmap) - (boundp bitmap) - (not recursed)) - (flymake--fringe-overlay-spec - (symbol-value bitmap) t) - (and flymake-fringe-indicator-position - bitmap - (propertize "!" 'display - (cons flymake-fringe-indicator-position - (if (listp bitmap) - bitmap - (list bitmap))))))) +(defun flymake--indicator-overlay-spec (indicator) + "Return INDICATOR as propertized string to use in error indicators." + (let* ((value (if (symbolp indicator) + (symbol-value indicator) + indicator)) + (indicator-car (if (listp value) + (car value) + value)) + (indicator-cdr (if (listp value) + (cdr value)))) + (cond + ((and (symbolp indicator-car) + flymake-fringe-indicator-position) + (propertize "!" 'display + (cons flymake-fringe-indicator-position + (if (listp value) + value + (list value))))) + ((and (stringp indicator-car) + flymake-margin-indicator-position) + (propertize "!" + 'display + `((margin ,flymake-margin-indicator-position) + ,(propertize + indicator-car + 'face + `(:inherit (,indicator-cdr + default))))))))) + +(defun flymake--resize-margins (&optional orig-width) + "Resize current window margins according to `flymake-margin-indicator-position'. +Return to original margin width if ORIG-WIDTH is non-nil." + (when (and (eq flymake-indicator-type 'margins) + flymake-autoresize-margins) + (cond + ((and orig-width flymake--original-margin-width) + (if (eq flymake-margin-indicator-position 'left-margin) + (setq-local left-margin-width flymake--original-margin-width) + (setq-local right-margin-width flymake--original-margin-width))) + (t + (if (eq flymake-margin-indicator-position 'left-margin) + (setq-local flymake--original-margin-width left-margin-width + left-margin-width 2) + (setq-local flymake--original-margin-width right-margin-width + right-margin-width 2)))) + ;; Apply margin to all windows avalaibles + (mapc (lambda (x) + (set-window-buffer x (window-buffer x))) + (get-buffer-window-list nil nil 'visible)))) (defun flymake--equal-diagnostic-p (a b) "Tell if A and B are equivalent `flymake--diag' objects." @@ -840,10 +937,13 @@ Return nil or the overlay created." type prop value))))) (default-maybe 'face 'flymake-error) (default-maybe 'before-string - (flymake--fringe-overlay-spec + (flymake--indicator-overlay-spec (flymake--lookup-type-property type - 'flymake-bitmap + (cond ((eq flymake-indicator-type 'fringes) + 'flymake-bitmap) + ((eq flymake-indicator-type 'margins) + 'flymake-margin-string)) (alist-get 'bitmap (alist-get type ; backward compat flymake-diagnostic-types-alist))))) ;; (default-maybe 'after-string @@ -1233,7 +1333,10 @@ Interactively, with a prefix arg, FORCE is t." nil)))))))) (defvar flymake-mode-map - (let ((map (make-sparse-keymap))) map) + (let ((map (make-sparse-keymap))) + (define-key map `[,flymake-fringe-indicator-position mouse-1] + #'flymake-show-buffer-diagnostics) + map) "Keymap for `flymake-mode'.") ;;;###autoload @@ -1285,6 +1388,9 @@ special *Flymake log* buffer." :group 'flymake :lighter (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t) (add-hook 'eldoc-documentation-functions 'flymake-eldoc-function t t) + ;; AutoResize margins. + (flymake--resize-margins) + ;; If Flymake happened to be already ON, we must cleanup ;; existing diagnostic overlays, lest we forget them by blindly ;; reinitializing `flymake--state' in the next line. @@ -1333,6 +1439,9 @@ special *Flymake log* buffer." :group 'flymake :lighter ;;+(remove-hook 'find-file-hook (function flymake-find-file-hook) t) (remove-hook 'eldoc-documentation-functions 'flymake-eldoc-function t) + ;; return margin to original size + (flymake--resize-margins t) + (when flymake-timer (cancel-timer flymake-timer) (setq flymake-timer nil)) @@ -1645,14 +1754,16 @@ correctly.") (let ((map (make-sparse-keymap))) ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events ;; and vice versa!! - (define-key map (vector 'mode-line mouse-wheel-down-event) - #'flymake--mode-line-counter-scroll-prev) - (define-key map [mode-line wheel-down] - #'flymake--mode-line-counter-scroll-next) - (define-key map (vector 'mode-line mouse-wheel-up-event) - #'flymake--mode-line-counter-scroll-next) - (define-key map [mode-line wheel-up] - #'flymake--mode-line-counter-scroll-prev) + (with-suppressed-warnings + ((obsolete mouse-wheel-up-event mouse-wheel-down-event)) + (define-key map (vector 'mode-line mouse-wheel-down-event) + #'flymake--mode-line-counter-scroll-prev) + (define-key map [mode-line wheel-down] + #'flymake--mode-line-counter-scroll-next) + (define-key map (vector 'mode-line mouse-wheel-up-event) + #'flymake--mode-line-counter-scroll-next) + (define-key map [mode-line wheel-up] + #'flymake--mode-line-counter-scroll-prev)) map)) (defun flymake--mode-line-counter-1 (type) @@ -1866,8 +1977,12 @@ buffer." (current-buffer))))) (with-current-buffer target (setq flymake--diagnostics-buffer-source source) - (display-buffer (current-buffer)) - (revert-buffer)))) + (revert-buffer) + (display-buffer (current-buffer) + `((display-buffer-reuse-window + display-buffer-below-selected) + (window-height . (lambda (window) + (fit-window-to-buffer window 10)))))))) ;;; Per-project diagnostic listing @@ -1967,8 +2082,11 @@ some of this variable's contents the diagnostic listings.") (with-current-buffer buffer (flymake-project-diagnostics-mode) (setq-local flymake--project-diagnostic-list-project prj) - (display-buffer (current-buffer)) - (revert-buffer)))) + (revert-buffer) + (display-buffer (current-buffer) + `((display-buffer-reuse-window + display-buffer-at-bottom) + (window-height . fit-window-to-buffer)))))) (defun flymake--update-diagnostics-listings (buffer) "Update diagnostics listings somehow relevant to BUFFER." diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index 92de2a2581f..18ab4911c89 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -232,8 +232,7 @@ CATEGORY is the overlay category. If it is nil, use the `glasses' category." (save-match-data (re-search-backward "\\<.") (looking-at glasses-uncapitalize-regexp)))) - (overlay-put o 'invisible t) - (overlay-put o 'after-string (downcase (match-string n)))))) + (overlay-put o 'display (downcase (match-string n)))))) ;; Separator change (when (and (not (string= glasses-original-separator glasses-separator)) (not (string= glasses-original-separator ""))) diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el index cc330688dc3..aef224ab3fa 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -108,11 +108,23 @@ ">>" "%=" ">>=" "--" "!" "..." "&^" "&^=" "~") "Go operators for tree-sitter font-locking.") +(defvar go-ts-mode--builtin-functions + '("append" "cap" "clear" "close" "complex" "copy" "delete" "imag" "len" "make" + "max" "min" "new" "panic" "print" "println" "real" "recover") + "Go built-in functions for tree-sitter font-locking.") + (defun go-ts-mode--iota-query-supported-p () "Return t if the iota query is supported by the tree-sitter-go grammar." (ignore-errors (or (treesit-query-string "" '((iota) @font-lock-constant-face) 'go) t))) +;; tree-sitter-go changed method_spec to method_elem in +;; https://github.com/tree-sitter/tree-sitter-go/commit/b82ab803d887002a0af11f6ce63d72884580bf33 +(defun go-ts-mode--method-elem-supported-p () + "Return t if Go grammar uses `method_elem' instead of `method_spec'." + (ignore-errors + (or (treesit-query-string "" '((method_elem) @cap) 'go) t))) + (defvar go-ts-mode--font-lock-settings (treesit-font-lock-rules :language 'go @@ -124,6 +136,16 @@ '((comment) @font-lock-comment-face) :language 'go + :feature 'builtin + `((call_expression + function: ((identifier) @font-lock-builtin-face + (:match ,(rx-to-string + `(seq bol + (or ,@go-ts-mode--builtin-functions) + eol)) + @font-lock-builtin-face)))) + + :language 'go :feature 'constant `([(false) (nil) (true)] @font-lock-constant-face ,@(when (go-ts-mode--iota-query-supported-p) @@ -136,12 +158,18 @@ '((["," "." ";" ":"]) @font-lock-delimiter-face) :language 'go + :feature 'operator + `([,@go-ts-mode--operators] @font-lock-operator-face) + + :language 'go :feature 'definition - '((function_declaration + `((function_declaration name: (identifier) @font-lock-function-name-face) (method_declaration name: (field_identifier) @font-lock-function-name-face) - (method_spec + (,(if (go-ts-mode--method-elem-supported-p) + 'method_elem + 'method_spec) name: (field_identifier) @font-lock-function-name-face) (field_declaration name: (field_identifier) @font-lock-property-name-face) @@ -256,7 +284,7 @@ (setq-local treesit-font-lock-feature-list '(( comment definition) ( keyword string type) - ( constant escape-sequence label number) + ( builtin constant escape-sequence label number) ( bracket delimiter error function operator property variable))) (treesit-major-mode-setup))) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index f10b047cc74..c16d78c5097 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -3854,12 +3854,12 @@ so they have been disabled.")) expr)))))))) -;; 'gud-lldb-history' and 'gud-gud-lldb-command-name' are required +;; 'gud-lldb-history' and 'gud-lldb-command-name' are required ;; because 'gud-symbol' uses their values if they are present. Their ;; names are deduced from the minor-mode name. (defvar gud-lldb-history nil) -(defcustom gud-gud-lldb-command-name "lldb" +(defcustom gud-lldb-command-name "lldb" "Default command to invoke LLDB in order to debug a program with it." :type 'string :version "30.1") @@ -4057,15 +4057,6 @@ consider to turn them off in this mode. This command runs functions from `lldb-mode-hook'." (interactive (list (gud-query-cmdline 'lldb))) - - (when (and gud-comint-buffer - (buffer-name gud-comint-buffer) - (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gud-lldb))) - (gdb-restore-windows) - ;; FIXME: Copied from gud-gdb, but what does that even say? - (error "Multiple debugging requires restarting in text command mode")) - (gud-common-init command-line nil 'gud-lldb-marker-filter) (setq-local gud-minor-mode 'lldb) @@ -4074,7 +4065,7 @@ This command runs functions from `lldb-mode-hook'." "\C-b" "Set breakpoint at current line.") (gud-def gud-tbreak - "_regexp-break %f:%l" + "_regexp-tbreak %f:%l" "\C-t" "Set temporary breakpoint at current line.") (gud-def gud-remove diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index 141bd18cf1e..687b176009e 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -308,7 +308,8 @@ quoted using shell quote syntax. "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) (setq inferior-lisp-buffer "*inferior-lisp*") - (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action)) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action))) ;;;###autoload (defalias 'run-lisp 'inferior-lisp) diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index 407ef230c32..f15edd040cc 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -35,7 +35,6 @@ (require 'treesit) (eval-when-compile - (require 'cl-lib) (require 'rx)) (declare-function treesit-induce-sparse-tree "treesit.c") @@ -293,6 +292,14 @@ values of OVERRIDE." (node-is "]]")) no-indent 0) ((and (n-p-gp "field" "table_constructor" "arguments") + lua-ts--multi-arg-function-call-matcher + lua-ts--last-arg-function-call-matcher) + standalone-parent lua-ts-indent-offset) + ((and (n-p-gp "}" "table_constructor" "arguments") + lua-ts--multi-arg-function-call-matcher + lua-ts--last-arg-function-call-matcher) + standalone-parent 0) + ((and (n-p-gp "field" "table_constructor" "arguments") lua-ts--multi-arg-function-call-matcher) parent lua-ts-indent-offset) ((and (n-p-gp "}" "table_constructor" "arguments") @@ -312,10 +319,15 @@ values of OVERRIDE." (and (parent-is "parameters") lua-ts--first-child-matcher) (and (parent-is "table_constructor") lua-ts--first-child-matcher)) standalone-parent lua-ts-indent-offset) + ((and (not lua-ts--comment-first-sibling-matcher) + (or (parent-is "arguments") + (parent-is "parameters") + (parent-is "table_constructor"))) + lua-ts--first-real-sibling-anchor 0) ((or (parent-is "arguments") (parent-is "parameters") (parent-is "table_constructor")) - (nth-sibling 1) 0) + standalone-parent lua-ts-indent-offset) ((and (n-p-gp "block" "function_definition" "parenthesized_expression") lua-ts--nested-function-block-matcher lua-ts--nested-function-block-include-matcher) @@ -338,6 +350,9 @@ values of OVERRIDE." lua-ts--nested-function-end-matcher lua-ts--nested-function-last-function-matcher) parent 0) + ((and (n-p-gp "end" "function_definition" "arguments") + lua-ts--top-level-function-call-matcher) + standalone-parent 0) ((n-p-gp "end" "function_definition" "arguments") parent 0) ((or (match "end" "function_definition") (node-is "end")) @@ -386,24 +401,39 @@ values of OVERRIDE." "Return t if NODE is a function_definition." (equal "function_definition" (treesit-node-type node))) +(defun lua-ts--g-parent (node) + "Return the grand-parent of NODE." + (let ((parent (treesit-node-parent node))) + (treesit-node-parent parent))) + +(defun lua-ts--g-g-parent (node) + "Return the great-grand-parent of NODE." + (treesit-node-parent (lua-ts--g-parent node))) + (defun lua-ts--g-g-g-parent (node) "Return the great-great-grand-parent of NODE." - (let* ((parent (treesit-node-parent node)) - (g-parent (treesit-node-parent parent)) - (g-g-parent (treesit-node-parent g-parent))) - (treesit-node-parent g-g-parent))) + (treesit-node-parent (lua-ts--g-g-parent node))) (defun lua-ts--multi-arg-function-call-matcher (_n parent &rest _) "Matches if PARENT has multiple arguments." (> (treesit-node-child-count (treesit-node-parent parent)) 3)) +(defun lua-ts--last-arg-function-call-matcher (node parent &rest _) + "Matches if NODE's PARENT is the last argument in a function call." + (let* ((g-parent (lua-ts--g-parent node)) + (last (1- (treesit-node-child-count g-parent t)))) + (treesit-node-eq parent (seq-elt (treesit-node-children g-parent t) last)))) + (defun lua-ts--nested-function-argument-matcher (node &rest _) "Matches if NODE is in a nested function argument." (save-excursion (goto-char (treesit-node-start node)) (treesit-beginning-of-defun) (backward-char 2) - (not (looking-at ")(")))) + (and (not (looking-at ")(")) + (not (equal "chunk" + (treesit-node-type + (lua-ts--g-parent (treesit-node-at (point))))))))) (defun lua-ts--nested-function-block-matcher (node &rest _) "Matches if NODE is in a nested function block." @@ -439,6 +469,26 @@ values of OVERRIDE." (treesit-induce-sparse-tree parent #'lua-ts--function-definition-p))) (= 1 (length (cadr sparse-tree))))) +(defun lua-ts--comment-first-sibling-matcher (node &rest _) + "Matches if NODE if it's previous sibling is a comment." + (let ((sibling (treesit-node-prev-sibling node))) + (equal "comment" (treesit-node-type sibling)))) + +(defun lua-ts--top-level-function-call-matcher (node &rest _) + "Matches if NODE is within a top-level function call." + (let* ((g-g-p (lua-ts--g-g-parent node)) + (g-g-g-p (lua-ts--g-g-g-parent node))) + (and (equal "function_call" (treesit-node-type g-g-p)) + (equal "chunk" (treesit-node-type g-g-g-p))))) + +(defun lua-ts--first-real-sibling-anchor (_n parent _) + "Return the start position of the first non-comment child of PARENT." + (treesit-node-start + (seq-first + (seq-filter + (lambda (n) (not (equal "comment" (treesit-node-type n)))) + (treesit-node-children parent t))))) + (defun lua-ts--variable-declaration-continuation (node &rest _) "Matches if NODE is part of a multi-line variable declaration." (treesit-parent-until node @@ -544,32 +594,32 @@ Calls REPORT-FN directly." (eq proc lua-ts--flymake-process)) (with-current-buffer (process-buffer proc) (goto-char (point-min)) - (cl-loop - while (search-forward-regexp - (rx (seq bol - (0+ alnum) ":" - (group (1+ digit)) ":" - (group (1+ digit)) "-" - (group (1+ digit)) ": " - (group (0+ nonl)) - eol)) - nil t) - for (beg . end) = (flymake-diag-region - source - (string-to-number (match-string 1)) - (string-to-number (match-string 2))) - for msg = (match-string 4) - for type = (if (string-match "^(W" msg) - :warning - :error) - when (and beg end) - collect (flymake-make-diagnostic source - beg - end - type - msg) - into diags - finally (funcall report-fn diags))) + (let (diags) + (while (search-forward-regexp + (rx bol (0+ alnum) ":" + (group (1+ digit)) ":" + (group (1+ digit)) "-" + (group (1+ digit)) ": " + (group (0+ nonl)) eol) + nil t) + (let* ((beg + (car (flymake-diag-region + source + (string-to-number (match-string 1)) + (string-to-number (match-string 2))))) + (end + (cdr (flymake-diag-region + source + (string-to-number (match-string 1)) + (string-to-number (match-string 3))))) + (msg (match-string 4)) + (type (if (string-prefix-p "(W" msg) + :warning + :error))) + (push (flymake-make-diagnostic + source beg end type msg) + diags))) + (funcall report-fn diags))) (flymake-log :warning "Canceling obsolete check %s" proc)) (kill-buffer (process-buffer proc))))))) (process-send-region lua-ts--flymake-process (point-min) (point-max)) @@ -765,7 +815,7 @@ Calls REPORT-FN directly." "vararg_expression")))) (text "comment")))) - ;; Imenu/Outline. + ;; Imenu/Outline/Which-function. (setq-local treesit-simple-imenu-settings `(("Requires" "\\`function_call\\'" @@ -777,9 +827,6 @@ Calls REPORT-FN directly." lua-ts--named-function-p nil))) - ;; Which-function. - (setq-local which-func-functions (treesit-defun-at-point)) - ;; Align. (setq-local align-indent-before-aligning t) diff --git a/lisp/progmodes/peg.el b/lisp/progmodes/peg.el new file mode 100644 index 00000000000..938f8da910d --- /dev/null +++ b/lisp/progmodes/peg.el @@ -0,0 +1,943 @@ +;;; peg.el --- Parsing Expression Grammars in Emacs Lisp -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2024 Free Software Foundation, Inc. +;; +;; Author: Helmut Eller <eller.helmut@gmail.com> +;; Maintainer: Stefan Monnier <monnier@iro.umontreal.ca> +;; Version: 1.0.1 +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; +;;; Commentary: +;; +;; This package implements Parsing Expression Grammars for Emacs Lisp. + +;; Parsing Expression Grammars (PEG) are a formalism in the spirit of +;; Context Free Grammars (CFG) with some simplifications which makes +;; the implementation of PEGs as recursive descent parsers particularly +;; simple and easy to understand [Ford, Baker]. +;; PEGs are more expressive than regexps and potentially easier to use. +;; +;; This file implements the macros `define-peg-rule', `with-peg-rules', and +;; `peg-parse' which parses the current buffer according to a PEG. +;; E.g. we can match integers with: +;; +;; (with-peg-rules +;; ((number sign digit (* digit)) +;; (sign (or "+" "-" "")) +;; (digit [0-9])) +;; (peg-run (peg number))) +;; or +;; (define-peg-rule digit () +;; [0-9]) +;; (peg-parse (number sign digit (* digit)) +;; (sign (or "+" "-" ""))) +;; +;; In contrast to regexps, PEGs allow us to define recursive "rules". +;; A "grammar" is a set of rules. A rule is written as (NAME PEX...) +;; E.g. (sign (or "+" "-" "")) is a rule with the name "sign". +;; The syntax for PEX (Parsing Expression) is a follows: +;; +;; Description Lisp Traditional, as in Ford's paper +;; =========== ==== =========== +;; Sequence (and E1 E2) e1 e2 +;; Prioritized Choice (or E1 E2) e1 / e2 +;; Not-predicate (not E) !e +;; And-predicate (if E) &e +;; Any character (any) . +;; Literal string "abc" "abc" +;; Character C (char C) 'c' +;; Zero-or-more (* E) e* +;; One-or-more (+ E) e+ +;; Optional (opt E) e? +;; Non-terminal SYMBOL A +;; Character range (range A B) [a-b] +;; Character set [a-b "+*" ?x] [a-b+*x] ;Note: it's a vector +;; Character classes [ascii cntrl] +;; Boolean-guard (guard EXP) +;; Syntax-Class (syntax-class NAME) +;; Local definitions (with RULES PEX...) +;; Indirect call (funcall EXP ARGS...) +;; and +;; Empty-string (null) ε +;; Beginning-of-Buffer (bob) +;; End-of-Buffer (eob) +;; Beginning-of-Line (bol) +;; End-of-Line (eol) +;; Beginning-of-Word (bow) +;; End-of-Word (eow) +;; Beginning-of-Symbol (bos) +;; End-of-Symbol (eos) +;; +;; Rules can refer to other rules, and a grammar is often structured +;; as a tree, with a root rule referring to one or more "branch +;; rules", all the way down to the "leaf rules" that deal with actual +;; buffer text. Rules can be recursive or mutually referential, +;; though care must be taken not to create infinite loops. +;; +;;;; Named rulesets: +;; +;; You can define a set of rules for later use with: +;; +;; (define-peg-ruleset myrules +;; (sign () (or "+" "-" "")) +;; (digit () [0-9]) +;; (nat () digit (* digit)) +;; (int () sign digit (* digit)) +;; (float () int "." nat)) +;; +;; and later refer to it: +;; +;; (with-peg-rules +;; (myrules +;; (complex float "+i" float)) +;; ... (peg-parse nat "," nat "," complex) ...) +;; +;;;; Parsing actions: +;; +;; PEXs also support parsing actions, i.e. Lisp snippets which are +;; executed when a pex matches. This can be used to construct syntax +;; trees or for similar tasks. The most basic form of action is +;; written as: +;; +;; (action FORM) ; evaluate FORM for its side-effects +;; +;; Actions don't consume input, but are executed at the point of +;; match. Another kind of action is called a "stack action", and +;; looks like this: +;; +;; `(VAR... -- FORM...) ; stack action +;; +;; A stack action takes VARs from the "value stack" and pushes the +;; results of evaluating FORMs to that stack. + +;; The value stack is created during the course of parsing. Certain +;; operators (see below) that match buffer text can push values onto +;; this stack. "Upstream" rules can then draw values from the stack, +;; and optionally push new ones back. For instance, consider this +;; very simple grammar: +;; +;; (with-peg-rules +;; ((query (+ term) (eol)) +;; (term key ":" value (opt (+ [space])) +;; `(k v -- (cons (intern k) v))) +;; (key (substring (and (not ":") (+ [word])))) +;; (value (or string-value number-value)) +;; (string-value (substring (+ [alpha]))) +;; (number-value (substring (+ [digit])) +;; `(val -- (string-to-number val)))) +;; (peg-run (peg query))) +;; +;; This invocation of `peg-run' would parse this buffer text: +;; +;; name:Jane age:30 +;; +;; And return this Elisp sexp: +;; +;; ((age . 30) (name . "Jane")) +;; +;; Note that, in complex grammars, some care must be taken to make +;; sure that the number and type of values drawn from the stack always +;; match those pushed. In the example above, both `string-value' and +;; `number-value' push a single value to the stack. Since the `value' +;; rule only includes these two sub-rules, any upstream rule that +;; makes use of `value' can be confident it will always and only push +;; a single value to the stack. +;; +;; Stack action forms are in a sense analogous to lambda forms: the +;; symbols before the "--" are the equivalent of lambda arguments, +;; while the forms after the "--" are return values. The difference +;; being that a lambda form can only return a single value, while a +;; stack action can push multiple values onto the stack. It's also +;; perfectly valid to use `(-- FORM...)' or `(VAR... --)': the former +;; pushes values to the stack without consuming any, and the latter +;; pops values from the stack and discards them. +;; +;;;; Derived Operators: +;; +;; The following operators are implemented as combinations of +;; primitive expressions: +;; +;; (substring E) ; Match E and push the substring for the matched region. +;; (region E) ; Match E and push the start and end positions. +;; (replace E RPL); Match E and replace the matched region with RPL. +;; (list E) ; Match E and push a list of the items that E produced. +;; +;; See `peg-ex-parse-int' in `peg-tests.el' for further examples. +;; +;; Regexp equivalents: +;; +;; Here a some examples for regexps and how those could be written as pex. +;; [Most are taken from rx.el] +;; +;; "^[a-z]*" +;; (and (bol) (* [a-z])) +;; +;; "\n[^ \t]" +;; (and "\n" (not [" \t"]) (any)) +;; +;; "\\*\\*\\* EOOH \\*\\*\\*\n" +;; "*** EOOH ***\n" +;; +;; "\\<\\(catch\\|finally\\)\\>[^_]" +;; (and (bow) (or "catch" "finally") (eow) (not "_") (any)) +;; +;; "[ \t\n]*:\\([^:]+\\|$\\)" +;; (and (* [" \t\n"]) ":" (or (+ (not ":") (any)) (eol))) +;; +;; "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*" +;; (and (bol) +;; "content-transfer-encoding:" +;; (* (opt "\n") ["\t "]) +;; "quoted-printable" +;; (* (opt "\n") ["\t "])) +;; +;; "\\$[I]d: [^ ]+ \\([^ ]+\\) " +;; (and "$Id: " (+ (not " ") (any)) " " (+ (not " ") (any)) " ") +;; +;; "^;;\\s-*\n\\|^\n" +;; (or (and (bol) ";;" (* (syntax-class whitespace)) "\n") +;; (and (bol) "\n")) +;; +;; "\\\\\\\\\\[\\w+" +;; (and "\\\\[" (+ (syntax-class word))) +;; +;; See ";;; Examples" in `peg-tests.el' for other examples. +;; +;;;; Rule argument and indirect calls: +;; +;; Rules can take arguments and those arguments can themselves be PEGs. +;; For example: +;; +;; (define-peg-rule 2-or-more (peg) +;; (funcall peg) +;; (funcall peg) +;; (* (funcall peg))) +;; +;; ... (peg-parse +;; ... +;; (2-or-more (peg foo)) +;; ... +;; (2-or-more (peg bar)) +;; ...) +;; +;;;; References: +;; +;; [Ford] Bryan Ford. Parsing Expression Grammars: a Recognition-Based +;; Syntactic Foundation. In POPL'04: Proceedings of the 31st ACM +;; SIGPLAN-SIGACT symposium on Principles of Programming Languages, +;; pages 111-122, New York, NY, USA, 2004. ACM Press. +;; http://pdos.csail.mit.edu/~baford/packrat/ +;; +;; [Baker] Baker, Henry G. "Pragmatic Parsing in Common Lisp". ACM Lisp +;; Pointers 4(2), April--June 1991, pp. 3--15. +;; http://home.pipeline.com/~hbaker1/Prag-Parse.html +;; +;; Roman Redziejowski does good PEG related research +;; http://www.romanredz.se/pubs.htm + +;;;; Todo: + +;; - Fix the exponential blowup in `peg-translate-exp'. +;; - Add a proper debug-spec for PEXs. + +;;; News: + +;; Since 1.0.1: +;; - Use OClosures to represent PEG rules when available, and let cl-print +;; display their source code. +;; - New PEX form (with RULES PEX...). +;; - Named rulesets. +;; - You can pass arguments to rules. +;; - New `funcall' rule to call rules indirectly (e.g. a peg you received +;; as argument). + +;; Version 1.0: +;; - New official entry points `peg` and `peg-run`. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(defvar peg--actions nil + "Actions collected along the current parse. +Used at runtime for backtracking. It's a list ((POS . THUNK)...). +Each THUNK is executed at the corresponding POS. Thunks are +executed in a postprocessing step, not during parsing.") + +(defvar peg--errors nil + "Data keeping track of the rightmost parse failure location. +It's a pair (POSITION . EXPS ...). POSITION is the buffer position and +EXPS is a list of rules/expressions that failed.") + +;;;; Main entry points + +(defmacro peg--when-fboundp (f &rest body) + (declare (indent 1) (debug (sexp body))) + (when (fboundp f) + (macroexp-progn body))) + +(peg--when-fboundp oclosure-define + (oclosure-define peg-function + "Parsing function built from PEG rule." + pexs) + + (cl-defmethod cl-print-object ((peg peg-function) stream) + (princ "#f<peg " stream) + (let ((args (help-function-arglist peg 'preserve-names))) + (if args + (prin1 args stream) + (princ "()" stream))) + (princ " " stream) + (prin1 (peg-function--pexs peg) stream) + (princ ">" stream))) + +(defmacro peg--lambda (pexs args &rest body) + (declare (indent 2) + (debug (&define form lambda-list def-body))) + (if (fboundp 'oclosure-lambda) + `(oclosure-lambda (peg-function (pexs ,pexs)) ,args . ,body) + `(lambda ,args . ,body))) + +;; Sometimes (with-peg-rules ... (peg-run (peg ...))) is too +;; longwinded for the task at hand, so `peg-parse' comes in handy. +(defmacro peg-parse (&rest pexs) + "Match PEXS at point. +PEXS is a sequence of PEG expressions, implicitly combined with `and'. +Returns STACK if the match succeed and signals an error on failure, +moving point along the way." + (if (and (consp (car pexs)) + (symbolp (caar pexs)) + (not (ignore-errors + (not (eq 'call (car (peg-normalize (car pexs)))))))) + ;; The first of `pexs' has not been defined as a rule, so assume + ;; that none of them have been and they should be fed to + ;; `with-peg-rules' + `(with-peg-rules ,pexs (peg-run (peg ,(caar pexs)) #'peg-signal-failure)) + `(peg-run (peg ,@pexs) #'peg-signal-failure))) + +(defmacro peg (&rest pexs) + "Return a PEG-matcher that matches PEXS." + (pcase (peg-normalize `(and . ,pexs)) + (`(call ,name) `#',(peg--rule-id name)) ;Optimize this case by η-reduction! + (exp `(peg--lambda ',pexs () ,(peg-translate-exp exp))))) + +;; There are several "infos we want to return" when parsing a given PEX: +;; 1- We want to return the success/failure of the parse. +;; 2- We want to return the data of the successful parse (the stack). +;; 3- We want to return the diagnostic of the failures. +;; 4- We want to perform the actions (upon parse success)! +;; `peg-parse' used an error signal to encode the (1) boolean, which +;; lets it return all the info conveniently but the error signal was sometimes +;; inconvenient. Other times one wants to just know (1) maybe without even +;; performing (4). +;; `peg-run' lets you choose all that, and by default gives you +;; (1) as a simple boolean, while also doing (2), and (4). + +(defun peg-run (peg-matcher &optional failure-function success-function) + "Parse with PEG-MATCHER at point and run the success/failure function. +If a match was found, move to the end of the match and call SUCCESS-FUNCTION +with one argument: a function which will perform all the actions collected +during the parse and then return the resulting stack (or t if empty). +If no match was found, move to the (rightmost) point of parse failure and call +FAILURE-FUNCTION with one argument, which is a list of PEG expressions that +failed at this point. +SUCCESS-FUNCTION defaults to `funcall' and FAILURE-FUNCTION +defaults to `ignore'." + (let ((peg--actions '()) (peg--errors '(-1))) + (if (funcall peg-matcher) + ;; Found a parse: run the actions collected along the way. + (funcall (or success-function #'funcall) + (lambda () + (save-excursion (peg-postprocess peg--actions)))) + (goto-char (car peg--errors)) + (when failure-function + (funcall failure-function (peg-merge-errors (cdr peg--errors))))))) + +(defmacro define-peg-rule (name args &rest pexs) + "Define PEG rule NAME as equivalent to PEXS. +The PEG expressions in PEXS are implicitly combined with the +sequencing `and' operator of PEG grammars." + (declare (indent 1)) + (let ((inline nil)) + (while (keywordp (car pexs)) + (pcase (pop pexs) + (:inline (setq inline (car pexs)))) + (setq pexs (cdr pexs))) + (let ((id (peg--rule-id name)) + (exp (peg-normalize `(and . ,pexs)))) + `(progn + (defalias ',id + (peg--lambda ',pexs ,args + ,(if inline + ;; Short-circuit to peg--translate in order to skip + ;; the extra failure-recording of `peg-translate-exp'. + ;; It also skips the cycle detection of + ;; `peg--translate-rule-body', which is not the main + ;; purpose but we can live with it. + (apply #'peg--translate exp) + (peg--translate-rule-body name exp)))) + (eval-and-compile + ;; FIXME: We shouldn't need this any more since the info is now + ;; stored in the function, but sadly we need to find a name's EXP + ;; during compilation (i.e. before the `defalias' is executed) + ;; as part of cycle-detection! + (put ',id 'peg--rule-definition ',exp) + ,@(when inline + ;; FIXME: Copied from `defsubst'. + `(;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664, Bug#43280, Bug#44209). + ,(byte-run--set-speed id nil -1) + (put ',id 'byte-optimizer #'byte-compile-inline-expand)))))))) + +(defmacro define-peg-ruleset (name &rest rules) + "Define a set of PEG rules for later use, e.g., in `with-peg-rules'." + (declare (indent 1)) + (let ((defs ()) + (aliases ())) + (dolist (rule rules) + (let* ((rname (car rule)) + (full-rname (format "%s %s" name rname))) + (push `(define-peg-rule ,full-rname . ,(cdr rule)) defs) + (push `(,(peg--rule-id rname) #',(peg--rule-id full-rname)) aliases))) + `(cl-flet ,aliases + ,@defs + (eval-and-compile (put ',name 'peg--rules ',aliases))))) + +(defmacro with-peg-rules (rules &rest body) + "Make PEG rules RULES available within the scope of BODY. +RULES is a list of rules of the form (NAME . PEXS), where PEXS is a sequence +of PEG expressions, implicitly combined with `and'. +RULES can also contain symbols in which case these must name +rulesets defined previously with `define-peg-ruleset'." + (declare (indent 1) (debug (sexp form))) ;FIXME: `sexp' is not good enough! + (let* ((rulesets nil) + (rules + ;; First, macroexpand the rules. + (delq nil + (mapcar (lambda (rule) + (if (symbolp rule) + (progn (push rule rulesets) nil) + (cons (car rule) (peg-normalize `(and . ,(cdr rule)))))) + rules))) + (ctx (assq :peg-rules macroexpand-all-environment))) + (macroexpand-all + `(cl-labels + ,(mapcar (lambda (rule) + ;; FIXME: Use `peg--lambda' as well. + `(,(peg--rule-id (car rule)) + () + ,(peg--translate-rule-body (car rule) (cdr rule)))) + rules) + ,@body) + `((:peg-rules ,@(append rules (cdr ctx))) + ,@macroexpand-all-environment)))) + +;;;;; Old entry points + +(defmacro peg-parse-exp (exp) + "Match the parsing expression EXP at point." + (declare (obsolete peg-parse "peg-0.9")) + `(peg-run (peg ,exp))) + +;;;; The actual implementation + +(defun peg--lookup-rule (name) + (or (cdr (assq name (cdr (assq :peg-rules macroexpand-all-environment)))) + ;; With `peg-function' objects, we can recover the PEG from which it was + ;; defined, but this info is not yet available at compile-time. :-( + ;;(let ((id (peg--rule-id name))) + ;; (peg-function--pexs (symbol-function id))) + (get (peg--rule-id name) 'peg--rule-definition))) + +(defun peg--rule-id (name) + (intern (format "peg-rule %s" name))) + +(define-error 'peg-search-failed "Parse error at %d (expecting %S)") + +(defun peg-signal-failure (failures) + (signal 'peg-search-failed (list (point) failures))) + +(defun peg-parse-at-point (peg-matcher) + "Parse text at point according to the PEG rule PEG-MATCHER." + (declare (obsolete peg-run "peg-1.0")) + (peg-run peg-matcher + #'peg-signal-failure + (lambda (f) (let ((r (funcall f))) (if (listp r) r))))) + +;; Internally we use a regularized syntax, e.g. we only have binary OR +;; nodes. Regularized nodes are lists of the form (OP ARGS...). +(cl-defgeneric peg-normalize (exp) + "Return a \"normalized\" form of EXP." + (error "Invalid parsing expression: %S" exp)) + +(cl-defmethod peg-normalize ((exp string)) + (let ((len (length exp))) + (cond ((zerop len) '(guard t)) + ((= len 1) `(char ,(aref exp 0))) + (t `(str ,exp))))) + +(cl-defmethod peg-normalize ((exp symbol)) + ;; (peg--lookup-rule exp) + `(call ,exp)) + +(cl-defmethod peg-normalize ((exp vector)) + (peg-normalize `(set . ,(append exp '())))) + +(cl-defmethod peg-normalize ((exp cons)) + (apply #'peg--macroexpand exp)) + +(defconst peg-leaf-types '(any call action char range str set + guard syntax-class = funcall)) + +(cl-defgeneric peg--macroexpand (head &rest args) + (cond + ((memq head peg-leaf-types) (cons head args)) + (t `(call ,head ,@args)))) + +(cl-defmethod peg--macroexpand ((_ (eql or)) &rest args) + (cond ((null args) '(guard nil)) + ((null (cdr args)) (peg-normalize (car args))) + (t `(or ,(peg-normalize (car args)) + ,(peg-normalize `(or . ,(cdr args))))))) + +(cl-defmethod peg--macroexpand ((_ (eql and)) &rest args) + (cond ((null args) '(guard t)) + ((null (cdr args)) (peg-normalize (car args))) + (t `(and ,(peg-normalize (car args)) + ,(peg-normalize `(and . ,(cdr args))))))) + +(cl-defmethod peg--macroexpand ((_ (eql *)) &rest args) + `(* ,(peg-normalize `(and . ,args)))) + +;; FIXME: this duplicates code; could use some loop to avoid that +(cl-defmethod peg--macroexpand ((_ (eql +)) &rest args) + (let ((e (peg-normalize `(and . ,args)))) + `(and ,e (* ,e)))) + +(cl-defmethod peg--macroexpand ((_ (eql opt)) &rest args) + (let ((e (peg-normalize `(and . ,args)))) + `(or ,e (guard t)))) + +(cl-defmethod peg--macroexpand ((_ (eql if)) &rest args) + `(if ,(peg-normalize `(and . ,args)))) + +(cl-defmethod peg--macroexpand ((_ (eql not)) &rest args) + `(not ,(peg-normalize `(and . ,args)))) + +(cl-defmethod peg--macroexpand ((_ (eql \`)) form) + (peg-normalize `(stack-action ,form))) + +(cl-defmethod peg--macroexpand ((_ (eql stack-action)) form) + (unless (member '-- form) + (error "Malformed stack action: %S" form)) + (let ((args (cdr (member '-- (reverse form)))) + (values (cdr (member '-- form)))) + (let ((form `(let ,(mapcar (lambda (var) `(,var (pop peg--stack))) args) + ,@(or (mapcar (lambda (val) `(push ,val peg--stack)) values) + '(nil))))) + `(action ,form)))) + +(defvar peg-char-classes + '(ascii alnum alpha blank cntrl digit graph lower multibyte nonascii print + punct space unibyte upper word xdigit)) + +(cl-defmethod peg--macroexpand ((_ (eql set)) &rest specs) + (cond ((null specs) '(guard nil)) + ((and (null (cdr specs)) + (let ((range (peg-range-designator (car specs)))) + (and range `(range ,(car range) ,(cdr range)))))) + (t + (let ((chars '()) (ranges '()) (classes '())) + (while specs + (let* ((spec (pop specs)) + (range (peg-range-designator spec))) + (cond (range + (push range ranges)) + ((peg-characterp spec) + (push spec chars)) + ((stringp spec) + (setq chars (append (reverse (append spec ())) chars))) + ((memq spec peg-char-classes) + (push spec classes)) + (t (error "Invalid set specifier: %S" spec))))) + (setq ranges (reverse ranges)) + (setq chars (delete-dups (reverse chars))) + (setq classes (reverse classes)) + (cond ((and (null ranges) + (null classes) + (cond ((null chars) '(guard nil)) + ((null (cdr chars)) `(char ,(car chars)))))) + (t `(set ,ranges ,chars ,classes))))))) + +(defun peg-range-designator (x) + (and (symbolp x) + (let ((str (symbol-name x))) + (and (= (length str) 3) + (eq (aref str 1) ?-) + (< (aref str 0) (aref str 2)) + (cons (aref str 0) (aref str 2)))))) + +;; characterp is new in Emacs 23. +(defun peg-characterp (x) + (if (fboundp 'characterp) + (characterp x) + (integerp x))) + +(cl-defmethod peg--macroexpand ((_ (eql list)) &rest args) + (peg-normalize + (let ((marker (make-symbol "magic-marker"))) + `(and (stack-action (-- ',marker)) + ,@args + (stack-action (-- + (let ((l '())) + (while + (let ((e (pop peg--stack))) + (cond ((eq e ',marker) nil) + ((null peg--stack) + (error "No marker on stack")) + (t (push e l) t)))) + l))))))) + +(cl-defmethod peg--macroexpand ((_ (eql substring)) &rest args) + (peg-normalize + `(and `(-- (point)) + ,@args + `(start -- (buffer-substring-no-properties start (point)))))) + +(cl-defmethod peg--macroexpand ((_ (eql region)) &rest args) + (peg-normalize + `(and `(-- (point)) + ,@args + `(-- (point))))) + +(cl-defmethod peg--macroexpand ((_ (eql replace)) pe replacement) + (peg-normalize + `(and (stack-action (-- (point))) + ,pe + (stack-action (start -- (progn + (delete-region start (point)) + (insert-before-markers ,replacement)))) + (stack-action (_ --))))) + +(cl-defmethod peg--macroexpand ((_ (eql quote)) _form) + (error "quote is reserved for future use")) + +(cl-defgeneric peg--translate (head &rest args) + (error "No translator for: %S" (cons head args))) + +(defun peg--translate-rule-body (name exp) + (let ((msg (condition-case err + (progn (peg-detect-cycles exp (list name)) nil) + (error (error-message-string err)))) + (code (peg-translate-exp exp))) + (cond + ((null msg) code) + (t (macroexp-warn-and-return msg code))))) + +;; This is the main translation function. +(defun peg-translate-exp (exp) + "Return the ELisp code to match the PE EXP." + ;; FIXME: This expansion basically duplicates `exp' in the output, which is + ;; a serious problem because it's done recursively, so it makes the output + ;; code's size exponentially larger than the input! + `(or ,(apply #'peg--translate exp) + (peg--record-failure ',exp))) ; for error reporting + +(define-obsolete-function-alias 'peg-record-failure + #'peg--record-failure "peg-1.0") +(defun peg--record-failure (exp) + (cond ((= (point) (car peg--errors)) + (setcdr peg--errors (cons exp (cdr peg--errors)))) + ((> (point) (car peg--errors)) + (setq peg--errors (list (point) exp)))) + nil) + +(cl-defmethod peg--translate ((_ (eql and)) e1 e2) + `(and ,(peg-translate-exp e1) + ,(peg-translate-exp e2))) + +;; Choicepoints are used for backtracking. At a choicepoint we save +;; enough state, so that we can continue from there if needed. +(defun peg--choicepoint-moved-p (choicepoint) + `(/= ,(car choicepoint) (point))) + +(defun peg--choicepoint-restore (choicepoint) + `(progn + (goto-char ,(car choicepoint)) + (setq peg--actions ,(cdr choicepoint)))) + +(defmacro peg--with-choicepoint (var &rest body) + (declare (indent 1) (debug (symbolp form))) + `(let ((,var (cons (make-symbol "point") (make-symbol "actions")))) + `(let ((,(car ,var) (point)) + (,(cdr ,var) peg--actions)) + ,@(list ,@body)))) + +(cl-defmethod peg--translate ((_ (eql or)) e1 e2) + (peg--with-choicepoint cp + `(or ,(peg-translate-exp e1) + (,@(peg--choicepoint-restore cp) + ,(peg-translate-exp e2))))) + +(cl-defmethod peg--translate ((_ (eql with)) rules &rest exps) + `(with-peg-rules ,rules ,(peg--translate `(and . ,exps)))) + +(cl-defmethod peg--translate ((_ (eql guard)) exp) exp) + +(defvar peg-syntax-classes + '((whitespace ?-) (word ?w) (symbol ?s) (punctuation ?.) + (open ?\() (close ?\)) (string ?\") (escape ?\\) (charquote ?/) + (math ?$) (prefix ?') (comment ?<) (endcomment ?>) + (comment-fence ?!) (string-fence ?|))) + +(cl-defmethod peg--translate ((_ (eql syntax-class)) class) + (let ((probe (assoc class peg-syntax-classes))) + (cond (probe `(when (looking-at ,(format "\\s%c" (cadr probe))) + (forward-char) + t)) + (t (error "Invalid syntax class: %S\nMust be one of: %s" class + (mapcar #'car peg-syntax-classes)))))) + +(cl-defmethod peg--translate ((_ (eql =)) string) + `(let ((str ,string)) + (when (zerop (length str)) + (error "Empty strings not allowed for =")) + (search-forward str (+ (point) (length str)) t))) + +(cl-defmethod peg--translate ((_ (eql *)) e) + `(progn (while ,(peg--with-choicepoint cp + `(if ,(peg-translate-exp e) + ;; Just as regexps do for the `*' operator, + ;; we allow the body of `*' loops to match + ;; the empty string, but we don't repeat the loop if + ;; we haven't moved, to avoid inf-loops. + ,(peg--choicepoint-moved-p cp) + ,(peg--choicepoint-restore cp) + nil))) + t)) + +(cl-defmethod peg--translate ((_ (eql if)) e) + (peg--with-choicepoint cp + `(when ,(peg-translate-exp e) + ,(peg--choicepoint-restore cp) + t))) + +(cl-defmethod peg--translate ((_ (eql not)) e) + (peg--with-choicepoint cp + `(unless ,(peg-translate-exp e) + ,(peg--choicepoint-restore cp) + t))) + +(cl-defmethod peg--translate ((_ (eql any)) ) + '(when (not (eobp)) + (forward-char) + t)) + +(cl-defmethod peg--translate ((_ (eql char)) c) + `(when (eq (char-after) ',c) + (forward-char) + t)) + +(cl-defmethod peg--translate ((_ (eql set)) ranges chars classes) + `(when (looking-at ',(peg-make-charset-regexp ranges chars classes)) + (forward-char) + t)) + +(defun peg-make-charset-regexp (ranges chars classes) + (when (and (not ranges) (not classes) (<= (length chars) 1)) + (error "Bug")) + (let ((rbracket (member ?\] chars)) + (minus (member ?- chars)) + (hat (member ?^ chars))) + (dolist (c '(?\] ?- ?^)) + (setq chars (remove c chars))) + (format "[%s%s%s%s%s%s]" + (if rbracket "]" "") + (if minus "-" "") + (mapconcat (lambda (x) (format "%c-%c" (car x) (cdr x))) ranges "") + (mapconcat (lambda (c) (format "[:%s:]" c)) classes "") + (mapconcat (lambda (c) (format "%c" c)) chars "") + (if hat "^" "")))) + +(cl-defmethod peg--translate ((_ (eql range)) from to) + `(when (and (char-after) + (<= ',from (char-after)) + (<= (char-after) ',to)) + (forward-char) + t)) + +(cl-defmethod peg--translate ((_ (eql str)) str) + `(when (looking-at ',(regexp-quote str)) + (goto-char (match-end 0)) + t)) + +(cl-defmethod peg--translate ((_ (eql call)) name &rest args) + `(,(peg--rule-id name) ,@args)) + +(cl-defmethod peg--translate ((_ (eql funcall)) exp &rest args) + `(funcall ,exp ,@args)) + +(cl-defmethod peg--translate ((_ (eql action)) form) + `(progn + (push (cons (point) (lambda () ,form)) peg--actions) + t)) + +(defvar peg--stack nil) +(defun peg-postprocess (actions) + "Execute \"actions\"." + (let ((peg--stack '()) + (forw-actions ())) + (pcase-dolist (`(,pos . ,thunk) actions) + (push (cons (copy-marker pos) thunk) forw-actions)) + (pcase-dolist (`(,pos . ,thunk) forw-actions) + (goto-char pos) + (funcall thunk)) + (or peg--stack t))) + +;; Left recursion is presumably a common mistake when using PEGs. +;; Here we try to detect such mistakes. Essentially we traverse the +;; graph as long as we can without consuming input. When we find a +;; recursive call we signal an error. + +(defun peg-detect-cycles (exp path) + "Signal an error on a cycle. +Otherwise traverse EXP recursively and return T if EXP can match +without consuming input. Return nil if EXP definitely consumes +input. PATH is the list of rules that we have visited so far." + (apply #'peg--detect-cycles path exp)) + +(cl-defgeneric peg--detect-cycles (head _path &rest args) + (error "No detect-cycle method for: %S" (cons head args))) + +(cl-defmethod peg--detect-cycles (path (_ (eql call)) name) + (if (member name path) + (error "Possible left recursion: %s" + (mapconcat (lambda (x) (format "%s" x)) + (reverse (cons name path)) " -> ")) + (let ((exp (peg--lookup-rule name))) + (if (null exp) + ;; If there's no rule by that name, either we'll fail at + ;; run-time or it will be defined later. In any case, at this + ;; point there's no evidence of a cycle, and if a cycle appears + ;; later we'll hopefully catch it when the rule gets defined. + ;; FIXME: In practice, if `name' is part of the cycle, we will + ;; indeed detect it when it gets defined, but OTOH if `name' + ;; is not part of a cycle but it *enables* a cycle because + ;; it matches the empty string (i.e. we should have returned t + ;; here), then we may not catch the problem at all :-( + nil + (peg-detect-cycles exp (cons name path)))))) + +(cl-defmethod peg--detect-cycles (path (_ (eql and)) e1 e2) + (and (peg-detect-cycles e1 path) + (peg-detect-cycles e2 path))) + +(cl-defmethod peg--detect-cycles (path (_ (eql or)) e1 e2) + (or (peg-detect-cycles e1 path) + (peg-detect-cycles e2 path))) + +(cl-defmethod peg--detect-cycles (path (_ (eql *)) e) + (peg-detect-cycles e path) + t) + +(cl-defmethod peg--detect-cycles (path (_ (eql if)) e) + (peg-unary-nullable e path)) +(cl-defmethod peg--detect-cycles (path (_ (eql not)) e) + (peg-unary-nullable e path)) + +(defun peg-unary-nullable (exp path) + (peg-detect-cycles exp path) + t) + +(cl-defmethod peg--detect-cycles (_path (_ (eql any))) nil) +(cl-defmethod peg--detect-cycles (_path (_ (eql char)) _c) nil) +(cl-defmethod peg--detect-cycles (_path (_ (eql set)) _r _c _k) nil) +(cl-defmethod peg--detect-cycles (_path (_ (eql range)) _c1 _c2) nil) +(cl-defmethod peg--detect-cycles (_path (_ (eql str)) s) (equal s "")) +(cl-defmethod peg--detect-cycles (_path (_ (eql guard)) _e) t) +(cl-defmethod peg--detect-cycles (_path (_ (eql =)) _s) nil) +(cl-defmethod peg--detect-cycles (_path (_ (eql syntax-class)) _n) nil) +(cl-defmethod peg--detect-cycles (_path (_ (eql action)) _form) t) + +(defun peg-merge-errors (exps) + "Build a more readable error message out of failed expression." + (let ((merged '())) + (dolist (exp exps) + (setq merged (peg-merge-error exp merged))) + merged)) + +(defun peg-merge-error (exp merged) + (apply #'peg--merge-error merged exp)) + +(cl-defgeneric peg--merge-error (_merged head &rest args) + (error "No merge-error method for: %S" (cons head args))) + +(cl-defmethod peg--merge-error (merged (_ (eql or)) e1 e2) + (peg-merge-error e2 (peg-merge-error e1 merged))) + +(cl-defmethod peg--merge-error (merged (_ (eql and)) e1 _e2) + ;; FIXME: Why is `e2' not used? + (peg-merge-error e1 merged)) + +(cl-defmethod peg--merge-error (merged (_ (eql str)) str) + ;;(add-to-list 'merged str) + (cl-adjoin str merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql call)) rule) + ;; (add-to-list 'merged rule) + (cl-adjoin rule merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql char)) char) + ;; (add-to-list 'merged (string char)) + (cl-adjoin (string char) merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql set)) r c k) + ;; (add-to-list 'merged (peg-make-charset-regexp r c k)) + (cl-adjoin (peg-make-charset-regexp r c k) merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql range)) from to) + ;; (add-to-list 'merged (format "[%c-%c]" from to)) + (cl-adjoin (format "[%c-%c]" from to) merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql *)) exp) + (peg-merge-error exp merged)) + +(cl-defmethod peg--merge-error (merged (_ (eql any))) + ;; (add-to-list 'merged '(any)) + (cl-adjoin '(any) merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql not)) x) + ;; (add-to-list 'merged `(not ,x)) + (cl-adjoin `(not ,x) merged :test #'equal)) + +(cl-defmethod peg--merge-error (merged (_ (eql action)) _action) merged) +(cl-defmethod peg--merge-error (merged (_ (eql null))) merged) + +(provide 'peg) +(require 'peg) + +(define-peg-rule null () :inline t (guard t)) +(define-peg-rule fail () :inline t (guard nil)) +(define-peg-rule bob () :inline t (guard (bobp))) +(define-peg-rule eob () :inline t (guard (eobp))) +(define-peg-rule bol () :inline t (guard (bolp))) +(define-peg-rule eol () :inline t (guard (eolp))) +(define-peg-rule bow () :inline t (guard (looking-at "\\<"))) +(define-peg-rule eow () :inline t (guard (looking-at "\\>"))) +(define-peg-rule bos () :inline t (guard (looking-at "\\_<"))) +(define-peg-rule eos () :inline t (guard (looking-at "\\_>"))) + +;;; peg.el ends here diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index f6c4dbed1e2..68685fb6625 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -656,7 +656,7 @@ create a new comment." ;;; Flymake support (defcustom perl-flymake-command '("perl" "-w" "-c") "External tool used to check Perl source code. -This is a non empty list of strings, the checker tool possibly +This is a non-empty list of strings: the checker tool possibly followed by required arguments. Once launched it will receive the Perl source to be checked as its standard input." :version "26.1" diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index a10e24f3e28..52fe4df9080 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -229,8 +229,8 @@ See the doc string of `project-find-functions' for the general form of the project instance object." (unless directory (setq directory (or project-current-directory-override default-directory))) - (let ((pr (project--find-in-directory directory)) - (non-essential (not maybe-prompt))) + (let* ((non-essential (not maybe-prompt)) + (pr (project--find-in-directory directory))) (cond (pr) ((unless project-current-directory-override @@ -291,7 +291,7 @@ headers search path, load path, class path, and so on." nil) (cl-defgeneric project-name (project) - "A human-readable name for the project. + "A human-readable name for the PROJECT. Nominally unique, but not enforced." (file-name-nondirectory (directory-file-name (project-root project)))) @@ -323,6 +323,13 @@ end it with `/'. DIR must be either `project-root' or one of (cl-defmethod project-root ((project (head transient))) (cdr project)) +(defvar project-files-relative-names nil + "If non-nil, `project-files' is allowed to return relative file names. +The file names should be relative to the project root. And this can +only happen when all returned files are in the same directory. +In other words, the DIRS argument of `project-files' has to be nil or a +list of only one element.") + (cl-defgeneric project-files (project &optional dirs) "Return a list of files in directories DIRS in PROJECT. DIRS is a list of absolute directories; it should be some @@ -345,7 +352,6 @@ to find the list of ignores for each directory." ;; expanded and not left for the shell command ;; to interpret. (localdir (file-name-unquote (file-local-name (expand-file-name dir)))) - (dfn (directory-file-name localdir)) (command (format "%s -H . %s -type f %s -print0" find-program (xref--find-ignores-arguments ignores "./") @@ -376,12 +382,14 @@ to find the list of ignores for each directory." (error "File listing failed: %s" (buffer-string)))) (goto-char pt) (while (search-forward "\0" nil t) - (push (buffer-substring-no-properties (1+ pt) (1- (point))) + (push (buffer-substring-no-properties (+ pt 2) (1- (point))) res) (setq pt (point))))) - (project--remote-file-names - (mapcar (lambda (s) (concat dfn s)) - (sort res #'string<))))) + (if project-files-relative-names + (sort res #'string<) + (project--remote-file-names + (mapcar (lambda (s) (concat localdir s)) + (sort res #'string<)))))) (defun project--remote-file-names (local-files) "Return LOCAL-FILES as if they were on the system of `default-directory'. @@ -640,7 +648,7 @@ See `project-vc-extra-root-markers' for the marker value format.") (list (project-root project))))) (declare-function vc-git--program-version "vc-git") -(declare-function vc-git--run-command-string "vc-git") +(declare-function vc-git-command "vc-git") (declare-function vc-hg-command "vc-hg") (defun project--vc-list-files (dir backend extra-ignores) @@ -689,9 +697,12 @@ See `project-vc-extra-root-markers' for the marker value format.") (mapcar (lambda (file) (unless (member file submodules) - (concat default-directory file))) + (if project-files-relative-names + file + (concat default-directory file)))) (split-string - (apply #'vc-git--run-command-string nil "ls-files" args) + (with-output-to-string + (apply #'vc-git-command standard-output 0 nil "ls-files" args)) "\0" t)))) (when (project--vc-merge-submodules-p default-directory) ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. @@ -716,7 +727,8 @@ See `project-vc-extra-root-markers' for the marker value format.") dir)) (args (list (concat "-mcard" (and include-untracked "u")) "--no-status" - "-0"))) + "-0")) + files) (when extra-ignores (setq args (nconc args (mapcan @@ -725,9 +737,12 @@ See `project-vc-extra-root-markers' for the marker value format.") extra-ignores)))) (with-temp-buffer (apply #'vc-hg-command t 0 "." "status" args) - (mapcar - (lambda (s) (concat default-directory s)) - (split-string (buffer-string) "\0" t))))))) + (setq files (split-string (buffer-string) "\0" t)) + (unless project-files-relative-names + (setq files (mapcar + (lambda (s) (concat default-directory s)) + files))) + files))))) (defun project--vc-merge-submodules-p (dir) (project--value-in-dir @@ -970,6 +985,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." (let* ((caller-dir default-directory) (pr (project-current t)) (default-directory (project-root pr)) + (project-files-relative-names t) (files (if (not current-prefix-arg) (project-files pr) @@ -1000,6 +1016,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." (require 'xref) (let* ((pr (project-current t)) (default-directory (project-root pr)) + ;; TODO: Make use of `project-files-relative-names' by + ;; searching each root separately (maybe in parallel, too). (files (project-files pr (cons (project-root pr) @@ -1054,7 +1072,8 @@ for VCS directories listed in `vc-directory-exclusion-list'." (interactive "P") (let* ((pr (project-current t)) (root (project-root pr)) - (dirs (list root))) + (dirs (list root)) + (project-files-relative-names t)) (project-find-file-in (or (thing-at-point 'filename) (and buffer-file-name (project--find-default-from buffer-file-name pr))) @@ -1130,7 +1149,12 @@ by the user at will." (if (> (length common-prefix) 0) (file-name-directory common-prefix)))) (cpd-length (length common-parent-directory)) - (prompt (if (zerop cpd-length) + (common-parent-directory (if (file-name-absolute-p (car all-files)) + common-parent-directory + (concat default-directory common-parent-directory))) + (prompt (if (and (zerop cpd-length) + all-files + (file-name-absolute-p (car all-files))) prompt (concat prompt (format " in %s" common-parent-directory)))) (included-cpd (when (member common-parent-directory all-files) @@ -1167,10 +1191,19 @@ by the user at will." (defun project--read-file-absolute (prompt all-files &optional predicate hist mb-default) - (project--completing-read-strict prompt - (project--file-completion-table all-files) - predicate - hist mb-default)) + (let* ((new-prompt (if (file-name-absolute-p (car all-files)) + prompt + (concat prompt " in " default-directory))) + ;; FIXME: Map relative names to absolute? + (ct (project--file-completion-table all-files)) + (file + (project--completing-read-strict new-prompt + ct + predicate + hist mb-default))) + (unless (file-name-absolute-p file) + (setq file (expand-file-name file))) + file)) (defun project--read-file-name ( project prompt all-files &optional predicate @@ -1215,6 +1248,7 @@ directories listed in `vc-directory-exclusion-list'." dirs) (project-files project dirs))) (completion-ignore-case read-file-name-completion-ignore-case) + (default-directory (project-root project)) (file (project--read-file-name project "Find file" all-files nil 'file-name-history diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 8279617b6e7..831bec7f4af 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -350,6 +350,7 @@ To customize the Python interpreter for interactive use, modify (define-key map "\C-c\C-e" #'python-shell-send-statement) (define-key map "\C-c\C-r" #'python-shell-send-region) (define-key map "\C-\M-x" #'python-shell-send-defun) + (define-key map "\C-c\C-b" #'python-shell-send-block) (define-key map "\C-c\C-c" #'python-shell-send-buffer) (define-key map "\C-c\C-l" #'python-shell-send-file) (define-key map "\C-c\C-z" #'python-shell-switch-to-shell) @@ -390,6 +391,8 @@ To customize the Python interpreter for interactive use, modify :help "Switch to running inferior Python process"] ["Eval string" python-shell-send-string :help "Eval string in inferior Python session"] + ["Eval block" python-shell-send-block + :help "Eval block in inferior Python session"] ["Eval buffer" python-shell-send-buffer :help "Eval buffer in inferior Python session"] ["Eval statement" python-shell-send-statement @@ -785,6 +788,7 @@ sign in chained assignment." "InterruptedError" "IsADirectoryError" "NotADirectoryError" "PermissionError" "ProcessLookupError" "RecursionError" "ResourceWarning" "StopAsyncIteration" "TimeoutError" + "ExceptionGroup" ;; OS specific "VMSError" "WindowsError" ) @@ -1018,9 +1022,9 @@ It makes underscores and dots word constituent chars.") "copyright" "credits" "exit" "license" "quit")) (defvar python--treesit-operators - '("-" "-=" "!=" "*" "**" "**=" "*=" "/" "//" "//=" "/=" "&" "%" "%=" - "^" "+" "->" "+=" "<" "<<" "<=" "<>" "=" ":=" "==" ">" ">=" ">>" "|" - "~" "@" "@=")) + '("-" "-=" "!=" "*" "**" "**=" "*=" "/" "//" "//=" "/=" "&" "&=" "%" "%=" + "^" "^=" "+" "->" "+=" "<" "<<" "<<=" "<=" "<>" "=" ":=" "==" ">" ">=" + ">>" ">>=" "|" "|=" "~" "@" "@=")) (defvar python--treesit-special-attributes '("__annotations__" "__closure__" "__code__" @@ -1052,6 +1056,7 @@ It makes underscores and dots word constituent chars.") "InterruptedError" "IsADirectoryError" "NotADirectoryError" "PermissionError" "ProcessLookupError" "RecursionError" "ResourceWarning" "StopAsyncIteration" "TimeoutError" + "ExceptionGroup" ;; OS specific "VMSError" "WindowsError" )) @@ -1202,17 +1207,20 @@ fontified." (class_definition name: (identifier) @font-lock-type-face) (parameters (identifier) @font-lock-variable-name-face) + (parameters (typed_parameter (identifier) @font-lock-variable-name-face)) (parameters (default_parameter name: (identifier) @font-lock-variable-name-face))) :feature 'builtin :language 'python - `(((identifier) @font-lock-builtin-face - (:match ,(rx-to-string - `(seq bol - (or ,@python--treesit-builtins - ,@python--treesit-special-attributes) - eol)) - @font-lock-builtin-face))) + `((call function: (identifier) @font-lock-builtin-face + (:match ,(rx-to-string + `(seq bol (or ,@python--treesit-builtins) eol)) + @font-lock-builtin-face)) + (attribute attribute: (identifier) @font-lock-builtin-face + (:match ,(rx-to-string + `(seq bol + (or ,@python--treesit-special-attributes) eol)) + @font-lock-builtin-face))) :feature 'decorator :language 'python @@ -1243,6 +1251,7 @@ fontified." @font-lock-variable-name-face) (named_expression name: (identifier) @font-lock-variable-name-face) + (for_statement left: (identifier) @font-lock-variable-name-face) (pattern_list [(identifier) (list_splat_pattern (identifier))] @font-lock-variable-name-face) @@ -2852,7 +2861,7 @@ virtualenv." :type '(repeat symbol)) (defcustom python-shell-compilation-regexp-alist - `((,(rx line-start (1+ (any " \t")) "File \"" + `((,(rx line-start (1+ (any " \t")) (? ?| (1+ (any " \t"))) "File \"" (group (1+ (not (any "\"<")))) ; avoid `<stdin>' &c "\", line " (group (1+ digit))) 1 2) @@ -2863,7 +2872,8 @@ virtualenv." "(" (group (1+ digit)) ")" (1+ (not (any "("))) "()") 1 2)) "`compilation-error-regexp-alist' for inferior Python." - :type '(alist regexp)) + :type '(alist regexp) + :version "30.1") (defcustom python-shell-dedicated nil "Whether to make Python shells dedicated by default. @@ -4136,6 +4146,28 @@ interactively." (save-excursion (python-nav-end-of-statement)) send-main msg t))) +(defun python-shell-send-block (&optional arg msg) + "Send the block at point to inferior Python process. +The block is delimited by `python-nav-beginning-of-block' and +`python-nav-end-of-block'. If optional argument ARG is non-nil +(interactively, the prefix argument), send the block body without +its header. If optional argument MSG is non-nil, force display +of a user-friendly message if there's no process running; this +always happens interactively." + (interactive (list current-prefix-arg t)) + (let ((beg (save-excursion + (when (python-nav-beginning-of-block) + (if (null arg) + (beginning-of-line) + (python-nav-end-of-statement) + (beginning-of-line 2))) + (point-marker))) + (end (save-excursion (python-nav-end-of-block))) + (python-indent-guess-indent-offset-verbose nil)) + (if (and beg end) + (python-shell-send-region beg end nil msg t) + (user-error "Can't get code block from current position.")))) + (defun python-shell-send-buffer (&optional send-main msg) "Send the entire buffer to inferior Python process. When optional argument SEND-MAIN is non-nil, allow execution of @@ -4706,6 +4738,8 @@ as one line, which is required by native completion." Optional argument PROCESS forces completions to be retrieved using that one instead of current buffer's process." (setq process (or process (get-buffer-process (current-buffer)))) + (unless process + (user-error "No active python inferior process")) (let* ((is-shell-buffer (derived-mode-p 'inferior-python-mode)) (line-start (if is-shell-buffer ;; Working on a shell buffer: use prompt end. @@ -6610,7 +6644,7 @@ returned as is." (defcustom python-flymake-command '("pyflakes") "The external tool that will be used to perform the syntax check. -This is a non empty list of strings, the checker tool possibly followed by +This is a non-empty list of strings: the checker tool possibly followed by required arguments. Once launched it will receive the Python source to be checked as its standard input. To use `flake8' you would set this to (\"flake8\" \"-\"). @@ -7176,6 +7210,7 @@ implementations: `python-mode' and `python-ts-mode'." python-nav-if-name-main python-nav-up-list python-remove-import + python-shell-send-block python-shell-send-buffer python-shell-send-defun python-shell-send-statement diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el index 7133cb0b5b0..5f4e11e0b4c 100644 --- a/lisp/progmodes/ruby-ts-mode.el +++ b/lisp/progmodes/ruby-ts-mode.el @@ -1171,7 +1171,22 @@ leading double colon is not added." "global_variable" ) eol) - #'ruby-ts--sexp-p))))) + #'ruby-ts--sexp-p)) + (text ,(lambda (node) + (or (member (treesit-node-type node) + '("comment" "string_content" "heredoc_content")) + ;; for C-M-f in hash[:key] and hash['key'] + (and (member (treesit-node-text node) + '("[" "]")) + (equal (treesit-node-type + (treesit-node-parent node)) + "element_reference")) + ;; for C-M-f in "abc #{ghi} def" + (and (member (treesit-node-text node) + '("#{" "}")) + (equal (treesit-node-type + (treesit-node-parent node)) + "interpolation")))))))) ;; AFAIK, Ruby can not nest methods (setq-local treesit-defun-prefer-top-level nil) diff --git a/lisp/progmodes/rust-ts-mode.el b/lisp/progmodes/rust-ts-mode.el index c67ac43e4d0..baf0e1ec013 100644 --- a/lisp/progmodes/rust-ts-mode.el +++ b/lisp/progmodes/rust-ts-mode.el @@ -48,6 +48,20 @@ :safe 'integerp :group 'rust) +(defcustom rust-ts-flymake-command '("clippy-driver" "-") + "The external tool that will be used to perform the check. +This is a non-empty list of strings: the checker tool possibly followed +by required arguments. Once launched it will receive the Rust source +to be checked as its standard input." + :version "30.1" + :type '(choice (const :tag "Clippy standalone" ("clippy-driver" "-")) + ;; TODO: Maybe add diagnostics filtering by file name, + ;; to limit non-project list to the current buffer. + ;; Or annotate them with file names, at least. + (const :tag "Clippy cargo" ("cargo" "clippy")) + (repeat :tag "Custom command" string)) + :group 'rust) + (defvar rust-ts-mode-prettify-symbols-alist '(("&&" . ?∧) ("||" . ?∨) ("<=" . ?≤) (">=" . ?≥) ("!=" . ?≠) @@ -115,7 +129,7 @@ "Rust built-in macros for tree-sitter font-locking.") (defvar rust-ts-mode--keywords - '("as" "async" "await" "break" "const" "continue" "dyn" "else" + '("as" "async" "await" "break" "const" "continue" "default" "dyn" "else" "enum" "extern" "fn" "for" "if" "impl" "in" "let" "loop" "match" "mod" "move" "pub" "ref" "return" "static" "struct" "trait" "type" "union" "unsafe" "use" "where" "while" (crate) (self) (super) @@ -162,8 +176,11 @@ :language 'rust :feature 'definition '((function_item name: (identifier) @font-lock-function-name-face) + (function_signature_item name: (identifier) @font-lock-function-name-face) (macro_definition "macro_rules!" @font-lock-constant-face) (macro_definition (identifier) @font-lock-preprocessor-face) + (token_binding_pattern + name: (metavariable) @font-lock-variable-name-face) (field_declaration name: (field_identifier) @font-lock-property-name-face) (parameter pattern: (_) @rust-ts-mode--fontify-pattern) (closure_parameters (_) @rust-ts-mode--fontify-pattern) @@ -196,7 +213,11 @@ :language 'rust :feature 'keyword - `([,@rust-ts-mode--keywords] @font-lock-keyword-face) + `([,@rust-ts-mode--keywords] @font-lock-keyword-face + ;; If these keyword are in a macro body, they're marked as + ;; identifiers. + ((identifier) @font-lock-keyword-face + (:match ,(rx bos (or "else" "in" "move") eos) @font-lock-keyword-face))) :language 'rust :feature 'number @@ -204,7 +225,9 @@ :language 'rust :feature 'operator - `([,@rust-ts-mode--operators] @font-lock-operator-face) + `([,@rust-ts-mode--operators] @font-lock-operator-face + (token_repetition_pattern ["$" "*" "+"] @font-lock-operator-face) + (token_repetition ["$" "*" "+"] @font-lock-operator-face)) :language 'rust :feature 'string @@ -234,8 +257,7 @@ (_ type: (scoped_identifier path: (identifier) @font-lock-type-face)))) (mod_item name: (identifier) @font-lock-constant-face) - (primitive_type) @font-lock-type-face - (type_identifier) @font-lock-type-face + [(fragment_specifier) (primitive_type) (type_identifier)] @font-lock-type-face ((scoped_identifier name: (identifier) @rust-ts-mode--fontify-tail)) ((scoped_identifier path: (identifier) @font-lock-type-face) (:match ,(rx bos @@ -245,8 +267,7 @@ eos) @font-lock-type-face)) ((scoped_identifier path: (identifier) @rust-ts-mode--fontify-scope)) - ((scoped_type_identifier path: (identifier) @rust-ts-mode--fontify-scope)) - (type_identifier) @font-lock-type-face) + ((scoped_type_identifier path: (identifier) @rust-ts-mode--fontify-scope))) :language 'rust :feature 'property @@ -280,7 +301,8 @@ (return_expression (identifier) @font-lock-variable-use-face) (tuple_expression (identifier) @font-lock-variable-use-face) (unary_expression (identifier) @font-lock-variable-use-face) - (while_expression condition: (identifier) @font-lock-variable-use-face)) + (while_expression condition: (identifier) @font-lock-variable-use-face) + (metavariable) @font-lock-variable-use-face) :language 'rust :feature 'escape-sequence @@ -417,6 +439,67 @@ See `prettify-symbols-compose-predicate'." "operator")) (_ t)))) +(defvar rust-ts--flymake-proc nil) + +(defun rust-ts-flymake--helper (process-name command parser-fn) + (when (process-live-p rust-ts--flymake-proc) + (kill-process rust-ts--flymake-proc)) + + (let ((source (current-buffer))) + (save-restriction + (widen) + (setq + rust-ts--flymake-proc + (make-process + :name process-name :noquery t :connection-type 'pipe + :buffer (generate-new-buffer (format " *%s*" process-name)) + :command command + :sentinel + (lambda (proc _event) + (when (and (eq 'exit (process-status proc)) (buffer-live-p source)) + (unwind-protect + (if (with-current-buffer source (eq proc rust-ts--flymake-proc)) + (with-current-buffer (process-buffer proc) + (funcall parser-fn proc source)) + (flymake-log :debug "Canceling obsolete check %s" + proc)) + (kill-buffer (process-buffer proc))))))) + (process-send-region rust-ts--flymake-proc (point-min) (point-max)) + (process-send-eof rust-ts--flymake-proc)))) + +(defun rust-ts-flymake (report-fn &rest _args) + "Rust backend for Flymake." + (unless (executable-find (car rust-ts-flymake-command)) + (error "Cannot find the rust flymake program: %s" (car rust-ts-flymake-command))) + + (rust-ts-flymake--helper + "rust-ts-flymake" + rust-ts-flymake-command + (lambda (_proc source) + (goto-char (point-min)) + (cl-loop + while (search-forward-regexp + (concat + "^\\(\\(?:warning\\|error\\|help\\).*\\)\n +--> [^:]+:" + "\\([0-9]+\\):\\([0-9]+\\)\\(\\(?:\n[^\n]+\\)*\\)\n\n") + nil t) + for msg1 = (match-string 1) + for msg2 = (match-string 4) + for (beg . end) = (flymake-diag-region + source + (string-to-number (match-string 2)) + (string-to-number (match-string 3))) + for type = (if (string-match "^warning" msg1) + :warning + :error) + collect (flymake-make-diagnostic source + beg + end + type + (concat msg1 msg2)) + into diags + finally (funcall report-fn diags))))) + ;;;###autoload (define-derived-mode rust-ts-mode prog-mode "Rust" "Major mode for editing Rust, powered by tree-sitter." @@ -460,10 +543,13 @@ See `prettify-symbols-compose-predicate'." (setq-local indent-tabs-mode nil treesit-simple-indent-rules rust-ts-mode--indent-rules) - ;; Electric + ;; Electric. (setq-local electric-indent-chars (append "{}():;,#" electric-indent-chars)) + ;; Flymake. + (add-hook 'flymake-diagnostic-functions #'rust-ts-flymake nil 'local) + ;; Navigation. (setq-local treesit-defun-type-regexp (regexp-opt '("enum_item" diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 67abab6913d..3242f1c345c 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -50,6 +50,7 @@ ;;; Code: (require 'lisp-mode) +(eval-when-compile 'subr-x) ;For `named-let'. (defvar scheme-mode-syntax-table (let ((st (make-syntax-table)) @@ -386,12 +387,12 @@ See `run-hooks'." (defvar scheme-font-lock-keywords scheme-font-lock-keywords-1 "Default expressions to highlight in Scheme modes.") -(defconst scheme-sexp-comment-syntax-table - (let ((st (make-syntax-table scheme-mode-syntax-table))) - (modify-syntax-entry ?\; "." st) - (modify-syntax-entry ?\n " " st) - (modify-syntax-entry ?# "'" st) - st)) +;; (defconst scheme-sexp-comment-syntax-table +;; (let ((st (make-syntax-table scheme-mode-syntax-table))) +;; (modify-syntax-entry ?\; "." st) +;; (modify-syntax-entry ?\n " " st) +;; (modify-syntax-entry ?# "'" st) +;; st)) (put 'lambda 'scheme-doc-string-elt 2) (put 'lambda* 'scheme-doc-string-elt 2) @@ -409,26 +410,82 @@ See `run-hooks'." (defun scheme-syntax-propertize (beg end) (goto-char beg) - (scheme-syntax-propertize-sexp-comment (point) end) + (scheme-syntax-propertize-sexp-comment end) + (scheme-syntax-propertize-regexp end) (funcall (syntax-propertize-rules ("\\(#\\);" (1 (prog1 "< cn" - (scheme-syntax-propertize-sexp-comment (point) end))))) + (scheme-syntax-propertize-sexp-comment end)))) + ("\\(#\\)/" (1 (when (null (nth 8 (save-excursion + (syntax-ppss (match-beginning 0))))) + (put-text-property + (match-beginning 1) + (match-end 1) + 'syntax-table (string-to-syntax "|")) + (scheme-syntax-propertize-regexp end) + nil)))) (point) end)) -(defun scheme-syntax-propertize-sexp-comment (_ end) - (let ((state (syntax-ppss))) +(defun scheme-syntax-propertize-sexp-comment (end) + (let ((state (syntax-ppss)) + ;; (beg (point)) + (checked (point))) (when (eq 2 (nth 7 state)) ;; It's a sexp-comment. Tell parse-partial-sexp where it ends. - (condition-case nil - (progn - (goto-char (+ 2 (nth 8 state))) - ;; FIXME: this doesn't handle the case where the sexp - ;; itself contains a #; comment. - (forward-sexp 1) - (put-text-property (1- (point)) (point) - 'syntax-table (string-to-syntax "> cn"))) - (scan-error (goto-char end)))))) + (named-let loop ((startpos (+ 2 (nth 8 state)))) + (let ((found nil)) + (while + (progn + (setq found nil) + (condition-case nil + (save-restriction + (narrow-to-region (point-min) end) + (goto-char startpos) + (forward-sexp 1) + ;; (cl-assert (> (point) beg)) + (setq found (point))) + (scan-error (goto-char end))) + ;; If there's a nested `#;', the syntax-tables will normally + ;; consider the `;' to start a normal comment, so the + ;; (forward-sexp 1) above may have landed at the wrong place. + ;; So look for `#;' in the text over which we jumped, and + ;; mark those we found as nested sexp-comments. + (let ((limit (min end (or found end)))) + (when (< checked limit) + (goto-char checked) + (while (and (re-search-forward "\\(#\\);" limit 'move) + ;; Skip those #; inside comments and strings. + (nth 8 (save-excursion + (parse-partial-sexp + startpos (match-beginning 0)))))) + (setq checked (point)) + (when (< (point) limit) + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table + (string-to-syntax "< cn")) + (loop (point)) + ;; Try the `forward-sexp' with the new text state. + t))))) + (when found + (goto-char found) + (put-text-property (1- found) found + 'syntax-table (string-to-syntax "> cn")))))))) + +(defun scheme-syntax-propertize-regexp (end) + (let* ((state (syntax-ppss)) + (within-str (nth 3 state)) + (start-delim-pos (nth 8 state))) + (when (and within-str + (char-equal ?# (char-after start-delim-pos))) + (while (and (re-search-forward "/" end 'move) + (eq -1 + (% (save-excursion + (backward-char) + (skip-chars-backward "\\\\")) + 2)))) + (when (< (point) end) + (put-text-property (match-beginning 0) (match-end 0) + 'syntax-table (string-to-syntax "|")))))) ;;;###autoload (define-derived-mode dsssl-mode scheme-mode "DSSSL" diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index ab95dc9f924..a348e9ba6fd 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1435,7 +1435,8 @@ If FORCE is non-nil and no process found, create one." (defun sh-show-shell () "Pop the shell interaction buffer." (interactive) - (pop-to-buffer (process-buffer (sh-shell-process t)) display-comint-buffer-action)) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer (process-buffer (sh-shell-process t)) display-comint-buffer-action))) (defun sh-send-text (text) "Send TEXT to `sh-shell-process'." @@ -3194,12 +3195,6 @@ shell command and conveniently use this command." (defvar-local sh--shellcheck-process nil) -(defalias 'sh--json-read - (if (fboundp 'json-parse-buffer) - (lambda () (json-parse-buffer :object-type 'alist)) - (require 'json) - 'json-read)) - (defun sh-shellcheck-flymake (report-fn &rest _args) "Flymake backend using the shellcheck program. Takes a Flymake callback REPORT-FN as argument, as expected of a @@ -3223,7 +3218,7 @@ member of `flymake-diagnostic-functions'." (with-current-buffer (process-buffer proc) (goto-char (point-min)) (thread-last - (sh--json-read) + (json-parse-buffer :object-type 'alist) (alist-get 'comments) (seq-filter (lambda (item) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 604f04a3d57..5273ba2bee1 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -3721,6 +3721,8 @@ prompts (`sql-output-newline-count' is positive). In this case: (save-excursion ;; Set product context (with-current-buffer sql-buffer + ;; Make sure point is at EOB before sending input to SQL. + (goto-char (point-max)) (when sql-debug-send (message ">>SQL> %S" s)) (insert "\n") diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 755c3db04fd..90ed8eb20e9 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1922,7 +1922,9 @@ to control which program to use when looking for matches." (hits nil) ;; Support for remote files. The assumption is that, if the ;; first file is remote, they all are, and on the same host. - (dir (file-name-directory (car files))) + (dir (if (file-name-absolute-p (car files)) + (file-name-directory (car files)) + default-directory)) (remote-id (file-remote-p dir)) ;; The 'auto' default would be fine too, but ripgrep can't handle ;; the options we pass in that case. @@ -2098,6 +2100,8 @@ Such as the current syntax table and the applied syntax properties." (pcase-let* ((`(,line ,file ,text) hit) (file (and file (concat xref--hits-remote-id file))) (buf (xref--find-file-buffer file)) + ;; This is fairly dangerouns, but improves performance + ;; for large lists, see https://debbugs.gnu.org/53749#227 (inhibit-modification-hooks t)) (if buf (with-current-buffer buf @@ -2129,6 +2133,8 @@ Such as the current syntax table and the applied syntax properties." (erase-buffer)) (insert text) (goto-char (point-min)) + (when syntax-needed + (syntax-ppss-flush-cache (point))) (xref--collect-matches-1 regexp file line (point) (point-max) diff --git a/lisp/repeat.el b/lisp/repeat.el index 0a59494c097..374a925d70c 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -553,20 +553,27 @@ This function can be used to force exit of repetition while it's active." (defun repeat-echo-message-string (keymap) "Return a string with the list of repeating keys in KEYMAP." (let (keys) - (map-keymap (lambda (key cmd) (and cmd (push key keys))) keymap) - (format-message "Repeat with %s%s" - (mapconcat (lambda (key) - (substitute-command-keys - (format "\\`%s'" - (key-description (vector key))))) - keys ", ") - (if repeat-exit-key - (substitute-command-keys - (format ", or exit with \\`%s'" - (if (key-valid-p repeat-exit-key) - repeat-exit-key - (key-description repeat-exit-key)))) - "")))) + (map-keymap (lambda (key cmd) (and cmd (push (cons key cmd) keys))) + keymap) + (format-message + "Repeat with %s%s" + (mapconcat (lambda (key-cmd) + (let ((key (car key-cmd)) + (cmd (cdr key-cmd))) + (if-let ((hint (and (symbolp cmd) + (get cmd 'repeat-hint)))) + ;; Reuse `read-multiple-choice' formatting. + (cdr (rmc--add-key-description (list key hint))) + (propertize (key-description (vector key)) + 'face 'read-multiple-choice-face)))) + keys ", ") + (if repeat-exit-key + (substitute-command-keys + (format ", or exit with \\`%s'" + (if (key-valid-p repeat-exit-key) + repeat-exit-key + (key-description repeat-exit-key)))) + "")))) (defun repeat-echo-message (keymap) "Display in the echo area the repeating keys defined by KEYMAP. diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index bce6a1805bc..c7e85b04cfd 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -350,7 +350,7 @@ nothing is dragged.") (defun ruler-mode-text-scaled-width (width) "Compute scaled text width according to current font scaling. -Convert a width of char units into a text-scaled char width units, +Convert a WIDTH of char units into a text-scaled char width units, for example `window-hscroll'." (/ (* width (frame-char-width)) (default-font-width))) @@ -528,7 +528,7 @@ START-EVENT is the mouse click event." (defvar ruler-mode-header-line-format-old nil "Hold previous value of `header-line-format'.") -(defvar ruler-mode-ruler-function 'ruler-mode-ruler +(defvar ruler-mode-ruler-function #'ruler-mode-ruler "Function to call to return ruler header line format. This variable is expected to be made buffer-local by modes.") @@ -563,7 +563,7 @@ format first." (ruler--save-header-line-format)) (setq ruler-mode enable))) (if ruler-mode - (add-hook 'post-command-hook 'force-mode-line-update nil t) + (add-hook 'post-command-hook #'force-mode-line-update nil t) ;; When `ruler-mode' is off restore previous header line format if ;; the current one is the ruler header line format. (when (eq header-line-format ruler-mode-header-line-format) @@ -571,7 +571,7 @@ format first." (when (local-variable-p 'ruler-mode-header-line-format-old) (setq header-line-format ruler-mode-header-line-format-old) (kill-local-variable 'ruler-mode-header-line-format-old))) - (remove-hook 'post-command-hook 'force-mode-line-update t))) + (remove-hook 'post-command-hook #'force-mode-line-update t))) ;; Add ruler-mode to the minor mode menu in the mode line (define-key mode-line-mode-menu [ruler-mode] @@ -625,7 +625,7 @@ mouse-2: unset goal column" (defsubst ruler-mode-space (width &rest props) "Return a single space string of WIDTH times the normal character width. Optional argument PROPS specifies other text properties to apply." - (apply 'propertize " " 'display (list 'space :width width) props)) + (apply #'propertize " " 'display (list 'space :width width) props)) (defun ruler-mode-ruler () "Compute and return a header line ruler." @@ -665,29 +665,26 @@ Optional argument PROPS specifies other text properties to apply." 'face 'ruler-mode-pad)) ;; Remember the scrollbar vertical type. (sbvt (car (window-current-scroll-bars))) - ;; Create an "clean" ruler. + ;; Create a "clean" ruler. (ruler - (propertize - ;; Make the part of header-line corresponding to the - ;; line-number display be blank, not filled with - ;; ruler-mode-basic-graduation-char. - (if display-line-numbers - (let* ((lndw (round (line-number-display-width 'columns))) - ;; We need a multibyte string here so we could - ;; later use aset to insert multibyte characters - ;; into that string. - (s (make-string lndw ?\s t))) - (concat s (make-string (- w lndw) - ruler-mode-basic-graduation-char t))) - (make-string w ruler-mode-basic-graduation-char t)) - 'face 'ruler-mode-default - 'local-map ruler-mode-map - 'help-echo (cond - (ruler-mode-show-tab-stops - ruler-mode-ruler-help-echo-when-tab-stops) - (goal-column - ruler-mode-ruler-help-echo-when-goal-column) - (ruler-mode-ruler-help-echo)))) + ;; Make the part of header-line corresponding to the + ;; line-number display be blank, not filled with + ;; ruler-mode-basic-graduation-char. + (if (> i 0) + (vconcat (make-vector i ?\s) + (make-vector (- w i) + ruler-mode-basic-graduation-char)) + (make-vector w ruler-mode-basic-graduation-char))) + (ruler-wide-props + `( face ruler-mode-default + ;; This is redundant with the minor mode map. + ;;local-map ruler-mode-map + help-echo ,(cond (ruler-mode-show-tab-stops + ruler-mode-ruler-help-echo-when-tab-stops) + (goal-column + ruler-mode-ruler-help-echo-when-goal-column) + (ruler-mode-ruler-help-echo)))) + (props nil) k c) ;; Setup the active area. (while (< i w) @@ -698,9 +695,7 @@ Optional argument PROPS specifies other text properties to apply." (setq c (number-to-string (/ j 10)) m (length c) k i) - (put-text-property - i (1+ i) 'face 'ruler-mode-column-number - ruler) + (push `(,i ,(1+ i) face ruler-mode-column-number) props) (while (and (> m 0) (>= k 0)) (aset ruler k (aref c (setq m (1- m)))) (setq k (1- k)))) @@ -712,62 +707,53 @@ Optional argument PROPS specifies other text properties to apply." ;; Show the `current-column' marker. ((= j (current-column)) (aset ruler i ruler-mode-current-column-char) - (put-text-property - i (1+ i) 'face 'ruler-mode-current-column - ruler)) + (push `(,i ,(1+ i) face ruler-mode-current-column) props)) ;; Show the `goal-column' marker. ((and goal-column (= j goal-column)) (aset ruler i ruler-mode-goal-column-char) - (put-text-property - i (1+ i) 'face 'ruler-mode-goal-column - ruler) - (put-text-property - i (1+ i) 'mouse-face 'mode-line-highlight - ruler) - (put-text-property - i (1+ i) 'help-echo ruler-mode-goal-column-help-echo - ruler)) + (push `(,i ,(1+ i) + help-echo ,ruler-mode-goal-column-help-echo + face ruler-mode-goal-column + mouse-face mode-line-highlight) + props)) ;; Show the `comment-column' marker. ((= j comment-column) (aset ruler i ruler-mode-comment-column-char) - (put-text-property - i (1+ i) 'face 'ruler-mode-comment-column - ruler) - (put-text-property - i (1+ i) 'mouse-face 'mode-line-highlight - ruler) - (put-text-property - i (1+ i) 'help-echo ruler-mode-comment-column-help-echo - ruler)) + (push `(,i ,(1+ i) + help-echo ,ruler-mode-comment-column-help-echo + face ruler-mode-comment-column + mouse-face mode-line-highlight) + props)) ;; Show the `fill-column' marker. ((= j fill-column) (aset ruler i ruler-mode-fill-column-char) - (put-text-property - i (1+ i) 'face 'ruler-mode-fill-column - ruler) - (put-text-property - i (1+ i) 'mouse-face 'mode-line-highlight - ruler) - (put-text-property - i (1+ i) 'help-echo ruler-mode-fill-column-help-echo - ruler)) + (push `(,i ,(1+ i) + help-echo ,ruler-mode-fill-column-help-echo + face ruler-mode-fill-column + mouse-face mode-line-highlight) + props)) ;; Show the `tab-stop-list' markers. ((and ruler-mode-show-tab-stops (= j (indent-next-tab-stop (1- j)))) (aset ruler i ruler-mode-tab-stop-char) - (put-text-property - i (1+ i) 'face 'ruler-mode-tab-stop - ruler))) + (push `(,i ,(1+ i) face ruler-mode-tab-stop) props))) (setq i (1+ i) j (1+ j))) - ;; Return the ruler propertized string. Using list here, - ;; instead of concat visually separate the different areas. - (if (nth 2 (window-fringes)) - ;; fringes outside margins. - (list "" (and (eq 'left sbvt) sb) lf lm - ruler rm rf (and (eq 'right sbvt) sb)) - ;; fringes inside margins. - (list "" (and (eq 'left sbvt) sb) lm lf - ruler rf rm (and (eq 'right sbvt) sb))))) + + (let ((ruler-str (concat ruler)) + (len (length ruler))) + (add-text-properties 0 len ruler-wide-props ruler-str) + (dolist (p (nreverse props)) + (add-text-properties (nth 0 p) (nth 1 p) (nthcdr 2 p) ruler-str)) + + ;; Return the ruler propertized string. Using list here, + ;; instead of concat visually separate the different areas. + (if (nth 2 (window-fringes)) + ;; fringes outside margins. + (list "" (and (eq 'left sbvt) sb) lf lm + ruler-str rm rf (and (eq 'right sbvt) sb)) + ;; fringes inside margins. + (list "" (and (eq 'left sbvt) sb) lm lf + ruler-str rf rm (and (eq 'right sbvt) sb)))))) (provide 'ruler-mode) diff --git a/lisp/shell.el b/lisp/shell.el index cd49d289403..e6b315ee5c0 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -923,7 +923,8 @@ Make the shell buffer the current buffer, and return it. (current-buffer))) ;; The buffer's window must be correctly set when we call comint ;; (so that comint sets the COLUMNS env var properly). - (pop-to-buffer buffer display-comint-buffer-action) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer buffer display-comint-buffer-action)) (with-connection-local-variables (when file-name diff --git a/lisp/simple.el b/lisp/simple.el index 0645f18cc78..deab52c4201 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1762,7 +1762,9 @@ not at the start of a line. When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not included in the count." - (declare (side-effect-free t)) + (declare (type (function ((or integer marker) (or integer marker) &optional t) + integer)) + (side-effect-free t)) (save-excursion (save-restriction (narrow-to-region start end) @@ -2703,15 +2705,14 @@ function as needed." (or (stringp doc) (fixnump doc) (fixnump (cdr-safe doc)))))) (pcase function - ((pred byte-code-function-p) + ((pred closurep) (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)) + ((or `(lambda ,_args . ,body) `(autoload ,_file . ,body)) (let ((doc (car body))) (when (funcall docstring-p doc) doc))) @@ -6883,7 +6884,8 @@ is active, and returns an integer or nil in the usual way. If you are using this in an editing command, you are most likely making a mistake; see the documentation of `set-mark'." - (declare (side-effect-free t)) + (declare (type (function (&optional t) (or integer null))) + (side-effect-free t)) (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) (marker-position (mark-marker)) (signal 'mark-inactive nil))) @@ -9856,16 +9858,6 @@ 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 @@ -10126,7 +10118,6 @@ minibuffer, but don't quit the completions window." (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 @@ -10159,13 +10150,7 @@ minibuffer, but don't quit the completions window." (with-current-buffer buffer (choose-completion-string choice buffer - ;; Don't allow affixes to replace the whole buffer when not - ;; in the minibuffer. Thus check for `completion-in-region-mode' - ;; to ignore non-nil value of `completion-use-base-affixes' set by - ;; `minibuffer-choose-completion'. - (or (and (not completion-in-region-mode) - completion-use-base-affixes base-affixes) - base-position + (or base-position ;; If all else fails, just guess. (list (choose-completion-guess-base-position choice))) insert-function))))) @@ -10321,11 +10306,9 @@ 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)) @@ -10863,86 +10846,6 @@ and setting it to nil." (setq buffer-invisibility-spec nil))) -(defvar read-passwd--mode-line-buffer nil - "Buffer to modify `mode-line-format' for showing/hiding passwords.") - -(defvar read-passwd--mode-line-icon nil - "Propertized mode line icon for showing/hiding passwords.") - -(defun read-passwd-toggle-visibility () - "Toggle minibuffer contents visibility. -Adapt also mode line." - (interactive) - (setq read-passwd--hide-password (not read-passwd--hide-password)) - (with-current-buffer read-passwd--mode-line-buffer - (setq read-passwd--mode-line-icon - `(:propertize - ,(if icon-preference - (icon-string - (if read-passwd--hide-password - 'read-passwd--show-password-icon - 'read-passwd--hide-password-icon)) - "") - mouse-face mode-line-highlight - local-map - (keymap - (mode-line keymap (mouse-1 . read-passwd-toggle-visibility))))) - (force-mode-line-update)) - (read-passwd--hide-password)) - -(define-minor-mode read-passwd-mode - "Toggle visibility of password in minibuffer." - :group 'mode-line - :group 'minibuffer - :keymap read-passwd-map - :version "30.1" - - (require 'icons) - ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is - ;; no corresponding Unicode char with a slash. So we use symbols as - ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for - ;; hiding the password. - (define-icon read-passwd--show-password-icon nil - '((image "reveal.svg" "reveal.pbm" :height (0.8 . em)) - (symbol "👁") - (text "<o>")) - "Mode line icon to show a hidden password." - :group mode-line-faces - :version "30.1" - :help-echo "mouse-1: Toggle password visibility") - (define-icon read-passwd--hide-password-icon nil - '((image "conceal.svg" "conceal.pbm" :height (0.8 . em)) - (symbol "⦵") - (text "<\\>")) - "Mode line icon to hide a visible password." - :group mode-line-faces - :version "30.1" - :help-echo "mouse-1: Toggle password visibility") - - (setq read-passwd--hide-password nil - ;; Stolen from `eldoc-minibuffer-message'. - read-passwd--mode-line-buffer - (window-buffer - (or (window-in-direction 'above (minibuffer-window)) - (minibuffer-selected-window) - (get-largest-window)))) - - (if read-passwd-mode - (with-current-buffer read-passwd--mode-line-buffer - ;; Add `read-passwd--mode-line-icon'. - (when (listp mode-line-format) - (setq mode-line-format - (cons '(:eval read-passwd--mode-line-icon) - mode-line-format)))) - (with-current-buffer read-passwd--mode-line-buffer - ;; Remove `read-passwd--mode-line-icon'. - (when (listp mode-line-format) - (setq mode-line-format (cdr mode-line-format))))) - - (when read-passwd-mode - (read-passwd-toggle-visibility))) - - (defvar messages-buffer-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map special-mode-map) @@ -11244,7 +11147,8 @@ killed." (defun lax-plist-get (plist prop) "Extract a value from a property list, comparing with `equal'." - (declare (pure t) (side-effect-free t) (obsolete plist-get "29.1")) + (declare (type (function (list t) t)) + (pure t) (side-effect-free t) (obsolete plist-get "29.1")) (plist-get plist prop #'equal)) (defun lax-plist-put (plist prop val) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 2ed97986fe7..c13c977938b 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -294,6 +294,7 @@ A nil value means don't show the file in the list." (border-width . 0) (menu-bar-lines . 0) (tool-bar-lines . 0) + (tab-bar-lines . 0) (unsplittable . t) (left-fringe . 0) ) @@ -304,7 +305,8 @@ attached to and added to this list before the new frame is initialized." :group 'speedbar :type '(repeat (cons :format "%v" (symbol :tag "Parameter") - (sexp :tag "Value")))) + (sexp :tag "Value"))) + :version "30.1") (defcustom speedbar-use-imenu-flag t "Non-nil means use imenu for file parsing, nil to use etags. diff --git a/lisp/subr.el b/lisp/subr.el index 90dbfc75d52..444afc0e486 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -451,7 +451,8 @@ This function accepts any number of arguments in ARGUMENTS. Also see `always'." ;; Not declared `side-effect-free' because we don't want calls to it ;; elided; see `byte-compile-ignore'. - (declare (pure t) (completion ignore)) + (declare (type (function (&rest t) null)) + (pure t) (completion ignore)) (interactive) nil) @@ -480,7 +481,8 @@ for the sake of consistency. To alter the look of the displayed error messages, you can use the `command-error-function' variable." - (declare (advertised-calling-convention (string &rest args) "23.1")) + (declare (type (function (string &rest t) nil)) + (advertised-calling-convention (string &rest args) "23.1")) (signal 'error (list (apply #'format-message args)))) (defun user-error (format &rest args) @@ -545,19 +547,22 @@ was called." "Return t if NUMBER is zero." ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because ;; = has a byte-code. - (declare (pure t) (side-effect-free t) + (declare (type (function (number) boolean)) + (pure t) (side-effect-free t) (compiler-macro (lambda (_) `(= 0 ,number)))) (= 0 number)) (defun fixnump (object) "Return t if OBJECT is a fixnum." - (declare (side-effect-free error-free)) + (declare (type (function (t) boolean)) + (side-effect-free error-free)) (and (integerp object) (<= most-negative-fixnum object most-positive-fixnum))) (defun bignump (object) "Return t if OBJECT is a bignum." - (declare (side-effect-free error-free)) + (declare (type (function (t) boolean)) + (side-effect-free error-free)) (and (integerp object) (not (fixnump object)))) (defun lsh (value count) @@ -570,7 +575,8 @@ Most uses of this function turn out to be mistakes. We recommend to use `ash' instead, unless COUNT could ever be negative, and if, when COUNT is negative, your program really needs the special treatment of negative COUNT provided by this function." - (declare (compiler-macro + (declare (type (function (integer integer) integer)) + (compiler-macro (lambda (form) (macroexp-warn-and-return (format-message "avoid `lsh'; use `ash' instead") @@ -748,7 +754,8 @@ treatment of negative COUNT provided by this function." If LIST is nil, return nil. If N is non-nil, return the Nth-to-last link of LIST. If N is bigger than the length of LIST, return LIST." - (declare (pure t) (side-effect-free t)) ; pure up to mutation + (declare (type (function (list &optional integer) list)) + (pure t) (side-effect-free t)) ; pure up to mutation (if n (and (>= n 0) (let ((m (safe-length list))) @@ -1585,7 +1592,8 @@ See also `current-global-map'.") (defun eventp (object) "Return non-nil if OBJECT is an input event or event object." - (declare (pure t) (side-effect-free error-free)) + (declare (type (function (t) boolean)) + (pure t) (side-effect-free error-free)) (or (integerp object) (and (if (consp object) (setq object (car object)) @@ -1652,7 +1660,8 @@ in the current Emacs session, then this function may return nil." (defsubst mouse-movement-p (object) "Return non-nil if OBJECT is a mouse movement event." - (declare (side-effect-free error-free)) + (declare (type (function (t) boolean)) + (side-effect-free error-free)) (eq (car-safe object) 'mouse-movement)) (defun mouse-event-p (object) @@ -1961,7 +1970,8 @@ be a list of the form returned by `event-start' and `event-end'." (defun log10 (x) "Return (log X 10), the log base 10 of X." - (declare (side-effect-free t) (obsolete log "24.4")) + (declare (type (function (number) float)) + (side-effect-free t) (obsolete log "24.4")) (log x 10)) (set-advertised-calling-convention @@ -2036,6 +2046,7 @@ instead; it will indirectly limit the specpdl stack size as well.") ;;;; Alternate names for functions - these are not being phased out. +(defalias 'drop #'nthcdr) (defalias 'send-string #'process-send-string) (defalias 'send-region #'process-send-region) (defalias 'string= #'string-equal) @@ -2270,7 +2281,9 @@ all symbols are bound before any of the VALUEFORMs are evalled." (let ((nbody (if (null binders) (macroexp-progn body) `(let ,(mapcar #'car binders) - ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) + ,@(mapcan (lambda (binder) + (and (cdr binder) (list `(setq ,@binder)))) + binders) ,@body)))) (cond ;; All bindings are recursive. @@ -3244,7 +3257,8 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defun memory-limit () "Return an estimate of Emacs virtual memory usage, divided by 1024." - (declare (side-effect-free error-free)) + (declare (type (function () integer)) + (side-effect-free error-free)) (let ((default-directory temporary-file-directory)) (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))) @@ -3381,92 +3395,6 @@ with Emacs. Do not call it directly in your own packages." t) (read-event))) -(defvar read-passwd-map - ;; BEWARE: `defconst' would purecopy it, breaking the sharing with - ;; minibuffer-local-map along the way! - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 - (define-key map "\t" #'read-passwd-toggle-visibility) - map) - "Keymap used while reading passwords.") - -(defvar read-passwd--hide-password t) - -(defun read-passwd--hide-password () - "Make password in minibuffer hidden or visible." - (let ((beg (minibuffer-prompt-end))) - (dotimes (i (1+ (- (buffer-size) beg))) - (if read-passwd--hide-password - (put-text-property - (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*))) - (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display))) - (put-text-property - (+ i beg) (+ 1 i beg) - 'help-echo "C-u: Clear password\nTAB: Toggle password visibility")))) - -;; Actually in textconv.c. -(defvar overriding-text-conversion-style) -(declare-function set-text-conversion-style "textconv.c") - -(defun read-passwd (prompt &optional confirm default) - "Read a password, prompting with PROMPT, and return it. -If optional CONFIRM is non-nil, read the password twice to make sure. -Optional DEFAULT is a default password to use instead of empty input. - -This function echoes `*' for each character that the user types. -You could let-bind `read-hide-char' to another hiding character, though. - -Once the caller uses the password, it can erase the password -by doing (clear-string STRING)." - (if confirm - (let (success) - (while (not success) - (let ((first (read-passwd prompt nil default)) - (second (read-passwd "Confirm password: " nil default))) - (if (equal first second) - (progn - (and (arrayp second) (not (eq first second)) (clear-string second)) - (setq success first)) - (and (arrayp first) (clear-string first)) - (and (arrayp second) (clear-string second)) - (message "Password not repeated accurately; please start over") - (sit-for 1)))) - success) - (let (minibuf) - (minibuffer-with-setup-hook - (lambda () - (setq minibuf (current-buffer)) - ;; Turn off electricity. - (setq-local post-self-insert-hook nil) - (setq-local buffer-undo-list t) - (setq-local select-active-regions nil) - (use-local-map read-passwd-map) - (setq-local inhibit-modification-hooks nil) ;bug#15501. - (setq-local show-paren-mode nil) ;bug#16091. - (setq-local inhibit--record-char t) - (read-passwd-mode 1) - (add-hook 'post-command-hook #'read-passwd--hide-password nil t)) - (unwind-protect - (let ((enable-recursive-minibuffers t) - (read-hide-char (or read-hide-char ?*)) - (overriding-text-conversion-style 'password)) - (read-string prompt nil t default)) ; t = "no history" - (when (buffer-live-p minibuf) - (with-current-buffer minibuf - (read-passwd-mode -1) - ;; Not sure why but it seems that there might be cases where the - ;; minibuffer is not always properly reset later on, so undo - ;; whatever we've done here (bug#11392). - (remove-hook 'after-change-functions - #'read-passwd--hide-password 'local) - (kill-local-variable 'post-self-insert-hook) - ;; And of course, don't keep the sensitive data around. - (erase-buffer) - ;; Then restore the previous text conversion style. - (when (fboundp 'set-text-conversion-style) - (set-text-conversion-style text-conversion-style))))))))) - (defvar read-number-history nil "The default history for the `read-number' function.") @@ -5762,13 +5690,19 @@ The SEPARATOR regexp defaults to \"\\s-+\"." (defun subst-char-in-string (fromchar tochar string &optional inplace) "Replace FROMCHAR with TOCHAR in STRING each time it occurs. Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr)) + (if (and (not inplace) + (if (multibyte-string-p string) + (> (max fromchar tochar) 127) + (> tochar 255))) + ;; Avoid quadratic behaviour from resizing replacement. + (string-replace (string fromchar) (string tochar) string) + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr))) (defun string-replace (from-string to-string in-string) "Replace FROM-STRING with TO-STRING in IN-STRING each time it occurs." @@ -6552,7 +6486,8 @@ To test whether a function can be called interactively, use `commandp'." ;; Kept around for now. See discussion at: ;; https://lists.gnu.org/r/emacs-devel/2020-08/msg00564.html - (declare (obsolete called-interactively-p "23.2") + (declare (type (function () boolean)) + (obsolete called-interactively-p "23.2") (side-effect-free error-free)) (called-interactively-p 'interactive)) @@ -7346,9 +7281,8 @@ sentence (see Info node `(elisp) Documentation Tips')." (internal--fill-string-single-line (apply #'format string objects))) (defun json-available-p () - "Return non-nil if Emacs has libjansson support." - (and (fboundp 'json--available-p) - (json--available-p))) + "Return non-nil if Emacs has native JSON support." + t) (defun ensure-list (object) "Return OBJECT as a list. @@ -7476,6 +7410,9 @@ CONDITION is either: * `major-mode': the buffer matches if the buffer's major mode is eq to the cons-cell's cdr. Prefer using `derived-mode' instead when both can work. + * `category': the buffer matches a category as a symbol if + the caller of `display-buffer' provides `(category . symbol)' + in its action argument. * `not': the cadr is interpreted as a negation of a condition. * `and': the cdr is a list of recursive conditions, that all have to be met. @@ -7504,6 +7441,8 @@ CONDITION is either: (push condition buffer-match-p--past-warnings)) (apply condition buffer-or-name (if args nil '(nil))))))) + (`(category . ,category) + (eq (alist-get 'category (cdar args)) category)) (`(major-mode . ,mode) (eq (buffer-local-value 'major-mode buffer) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index fa22500a04e..dac57ce2070 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -104,10 +104,11 @@ For easier selection of tabs by their numbers, consider customizing (const alt)) :initialize #'custom-initialize-default :set (lambda (sym val) + (when tab-bar-mode + (tab-bar--undefine-keys)) (set-default sym val) ;; Reenable the tab-bar with new keybindings (when tab-bar-mode - (tab-bar--undefine-keys) (tab-bar--define-keys))) :group 'tab-bar :version "27.1") @@ -115,21 +116,17 @@ For easier selection of tabs by their numbers, consider customizing (defun tab-bar--define-keys () "Install key bindings to switch between tabs if so configured." (when tab-bar-select-tab-modifiers - (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0))) - #'tab-recent) + (define-key tab-bar-mode-map + (vector (append tab-bar-select-tab-modifiers (list ?0))) + #'tab-recent) (dotimes (i 8) - (global-set-key (vector (append tab-bar-select-tab-modifiers - (list (+ i 1 ?0)))) - #'tab-bar-select-tab)) - (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9))) - #'tab-last)) - ;; Don't override user customized key bindings - (unless (global-key-binding [(control tab)]) - (global-set-key [(control tab)] #'tab-next)) - (unless (global-key-binding [(control shift tab)]) - (global-set-key [(control shift tab)] #'tab-previous)) - (unless (global-key-binding [(control shift iso-lefttab)]) - (global-set-key [(control shift iso-lefttab)] #'tab-previous)) + (define-key tab-bar-mode-map + (vector (append tab-bar-select-tab-modifiers + (list (+ i 1 ?0)))) + #'tab-bar-select-tab)) + (define-key tab-bar-mode-map + (vector (append tab-bar-select-tab-modifiers (list ?9))) + #'tab-last)) ;; Replace default value with a condition that supports displaying ;; global-mode-string in the tab bar instead of the mode line. @@ -144,12 +141,18 @@ For easier selection of tabs by their numbers, consider customizing (defun tab-bar--undefine-keys () "Uninstall key bindings previously bound by `tab-bar--define-keys'." - (when (eq (global-key-binding [(control tab)]) 'tab-next) - (global-unset-key [(control tab)])) - (when (eq (global-key-binding [(control shift tab)]) 'tab-previous) - (global-unset-key [(control shift tab)])) - (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous) - (global-unset-key [(control shift iso-lefttab)]))) + (when tab-bar-select-tab-modifiers + (define-key tab-bar-mode-map + (vector (append tab-bar-select-tab-modifiers (list ?0))) + nil t) + (dotimes (i 8) + (define-key tab-bar-mode-map + (vector (append tab-bar-select-tab-modifiers + (list (+ i 1 ?0)))) + nil t)) + (define-key tab-bar-mode-map + (vector (append tab-bar-select-tab-modifiers (list ?9))) + nil t))) (defun tab-bar--load-buttons () "Load the icons for the tab buttons." @@ -239,6 +242,20 @@ a list of frames to update." (if (and tab-bar-mode (eq tab-bar-show t)) 1 0)) (assq-delete-all 'tab-bar-lines default-frame-alist))))) +(defun tab-bar-mode--tab-key-bind (map key binding) + ;; Don't override user customized global key bindings + (define-key map key + `(menu-item "" ,binding + :filter ,(lambda (cmd) (unless (global-key-binding key) cmd))))) + +(defvar tab-bar-mode-map + (let ((map (make-sparse-keymap))) + (tab-bar-mode--tab-key-bind map [(control tab)] #'tab-next) + (tab-bar-mode--tab-key-bind map [(control shift tab)] #'tab-previous) + (tab-bar-mode--tab-key-bind map [(control shift iso-lefttab)] #'tab-previous) + map) + "Tab Bar mode map.") + (define-minor-mode tab-bar-mode "Toggle the tab bar in all graphical frames (Tab Bar mode)." :global t @@ -281,9 +298,13 @@ It returns a list of the form (KEY KEY-BINDING CLOSE-P), where: nil otherwise." (setq tab-bar--dragging-in-progress nil) (if (posn-window posn) - (let ((caption (car (posn-string posn)))) - (when caption - (get-text-property 0 'menu-item caption))) + (let* ((caption (car (posn-string posn))) + (menu-item (when caption + (get-text-property 0 'menu-item caption)))) + (when (equal menu-item '(global ignore nil)) + (setf (nth 1 menu-item) + (key-binding (vector 'tab-bar last-nonmenu-event) t))) + menu-item) ;; Text-mode emulation of switching tabs on the tab bar. ;; This code is used when you click the mouse in the tab bar ;; on a console which has no window system but does have a mouse. @@ -315,7 +336,7 @@ existing tab." (setq tab-bar--dragging-in-progress t) ;; Don't close the tab when clicked on the close button. Also ;; don't add new tab on down-mouse. Let `tab-bar-mouse-1' do this. - (unless (or (memq (car item) '(add-tab history-back history-forward)) + (unless (or (memq (car item) '(add-tab history-back history-forward global)) (nth 2 item)) (if (functionp (nth 1 item)) (call-interactively (nth 1 item)) @@ -330,7 +351,8 @@ regardless of where you click on it. Also add a new tab." (let* ((item (tab-bar--event-to-item (event-start event))) (tab-number (tab-bar--key-to-number (nth 0 item)))) (cond - ((and (memq (car item) '(add-tab history-back history-forward)) + ((and (memq (car item) '(add-tab history-back history-forward global)) + (not (eq (nth 1 item) 'tab-bar-mouse-1)) (functionp (nth 1 item))) (call-interactively (nth 1 item))) ((and (nth 2 item) (not (eq tab-number t))) @@ -451,8 +473,8 @@ appropriate." (tab-bar-select-tab number)))) ;; Cancel the timer. (cancel-timer timer))) - ((and (memq (car item) '(add-tab history-back - history-forward)) + ((and (memq (car item) '( add-tab history-back + history-forward global)) (functionp (cadr item))) ;; This is some kind of button. Wait for the ;; tap to complete and press it. @@ -1098,7 +1120,9 @@ When `tab-bar-format-global' is added to `tab-bar-format' then modes that display information on the mode line using `global-mode-string' will display the same text on the tab bar instead." - `((global menu-item ,(format-mode-line global-mode-string) ignore))) + (mapcar (lambda (string) + `(global menu-item ,(format-mode-line string) ignore)) + global-mode-string)) (defun tab-bar-format-list (format-list) (let ((i 0)) @@ -1292,6 +1316,9 @@ tab bar might wrap to the second line when it shouldn't.") frame 'buffer-list))) (bbl (seq-filter #'buffer-live-p (frame-parameter frame 'buried-buffer-list)))) + (when tab-bar-select-restore-context + (window-point-context-set)) + `(tab (name . ,(if tab-explicit-name (alist-get 'name tab) @@ -1420,13 +1447,11 @@ if it was visiting a file." (buffer-file-name old-buffer))) (name (or file (and (bufferp old-buffer) - (fboundp 'buffer-last-name) (buffer-last-name old-buffer)) old-buffer)) (new-buffer (generate-new-buffer - (format "*Old buffer %s*" name)))) + (format " *Old buffer %s*" name)))) (with-current-buffer new-buffer - (set-auto-mode) (insert (format-message "This window displayed the %s `%s'.\n" (if file "file" "buffer") name)) @@ -1439,9 +1464,19 @@ if it was visiting a file." (set-window-point window (nth 3 quad)))) (insert "\n")) (goto-char (point-min)) - (setq buffer-read-only t) + (special-mode) (set-window-buffer window new-buffer)))))) +(defcustom tab-bar-select-restore-context t + "If this is non-nil, try to restore window points from their contexts. +This will try to find the same position in every window where point was +before switching away from this tab. After selecting this tab, +point in every window will be moved to its previous position +in the buffer even when the buffer was modified." + :type 'boolean + :group 'tab-bar + :version "30.1") + (defvar tab-bar-minibuffer-restore-tab nil "Tab number for `tab-bar-minibuffer-restore-tab'.") @@ -1481,7 +1516,7 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (when (and read-minibuffer-restore-windows minibuffer-was-active (not tab-bar-minibuffer-restore-tab)) (setq-local tab-bar-minibuffer-restore-tab (1+ from-index)) - (add-hook 'minibuffer-exit-hook 'tab-bar-minibuffer-restore-tab nil t)) + (add-hook 'minibuffer-exit-hook #'tab-bar-minibuffer-restore-tab nil t)) (unless (eq from-index to-index) (let* ((from-tab (tab-bar--tab)) @@ -1539,6 +1574,9 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (select-window (get-mru-window))) (window-state-put ws nil 'safe))) + (when tab-bar-select-restore-context + (window-point-context-use)) + ;; Select the minibuffer when it was active before switching tabs (when (and minibuffer-was-active (active-minibuffer-window)) (select-window (active-minibuffer-window))) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index cc60f94c9c5..6898ba53e02 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -210,6 +210,11 @@ If the value is a function, call it with no arguments." 'help-echo "Click to add tab") "Button for creating a new tab.") +(defvar tab-line-new-button-functions + '(tab-line-tabs-window-buffers + tab-line-tabs-fixed-window-buffers) + "Functions of `tab-line-tabs-function' for which to show a new button.") + (defcustom tab-line-close-button-show t "Defines where to show the close tab button. If t, show the close tab button on all tabs. @@ -333,19 +338,21 @@ If truncated, append ellipsis per `tab-line-tab-name-ellipsis'." 'help-echo tab-name)))) -(defcustom tab-line-tabs-function #'tab-line-tabs-window-buffers +(defcustom tab-line-tabs-function #'tab-line-tabs-fixed-window-buffers "Function to get a list of tabs to display in the tab line. This function should return either a list of buffers whose names will be displayed, or just a list of strings to display in the tab line. -By default, use function `tab-line-tabs-window-buffers' that -returns a list of buffers associated with the selected window. +By default, use function `tab-line-tabs-fixed-window-buffers' that +returns a list of buffers associated with the selected window where +buffers always keep the original order after switching buffers. When `tab-line-tabs-mode-buffers', return a list of buffers with the same major mode as the current buffer. When `tab-line-tabs-buffer-groups', return a list of buffers -grouped either by `tab-line-tabs-buffer-group-function', when set, -or by `tab-line-tabs-buffer-groups'." +grouped by `tab-line-tabs-buffer-group-function'." :type '(choice (const :tag "Window buffers" tab-line-tabs-window-buffers) + (const :tag "Window buffers with fixed order" + tab-line-tabs-fixed-window-buffers) (const :tag "Same mode buffers" tab-line-tabs-mode-buffers) (const :tag "Grouped buffers" @@ -377,16 +384,58 @@ Used only for `tab-line-tabs-mode-buffers' and `tab-line-tabs-buffer-groups'.") (derived-mode-p mode))) (funcall tab-line-tabs-buffer-list-function))))) -(defvar tab-line-tabs-buffer-group-function nil +(defcustom tab-line-tabs-buffer-group-function + #'tab-line-tabs-buffer-group-by-mode "Function to add a buffer to the appropriate group of tabs. -Takes a buffer as arg and should return a group name as a string. -If the return value is nil, the buffer should be filtered out.") +Takes a buffer as argument and should return a group name as a string. +If the return value is nil, the buffer has no group, so \"No group\" +is displayed instead of a group name and the buffer is not grouped +together with other buffers. +If the value is `tab-line-tabs-buffer-group-by-mode', +use mode-to-group mappings in `tab-line-tabs-buffer-groups' +to group by major mode. If the value is +`tab-line-tabs-buffer-group-by-project' use the project name +as a group name." + :type '(choice (const :tag "Group by mode" + tab-line-tabs-buffer-group-by-mode) + (const :tag "Group by project name" + tab-line-tabs-buffer-group-by-project) + (function :tag "Custom function")) + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + (force-mode-line-update)) + :group 'tab-line + :version "30.1") -(defvar tab-line-tabs-buffer-group-sort-function nil - "Function to sort buffers in a group.") +(defcustom tab-line-tabs-buffer-group-sort-function + #'tab-line-tabs-buffer-group-sort-by-name + "Function to sort buffers in a group." + :type '(choice (const :tag "Don't sort" nil) + (const :tag "Sort by name alphabetically" + tab-line-tabs-buffer-group-sort-by-name) + (function :tag "Custom function")) + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + (force-mode-line-update)) + :group 'tab-line + :version "30.1") -(defvar tab-line-tabs-buffer-groups-sort-function #'string< - "Function to sort group names.") +(defun tab-line-tabs-buffer-group-sort-by-name (a b) + (string< (buffer-name a) (buffer-name b))) + +(defcustom tab-line-tabs-buffer-groups-sort-function #'string< + "Function to sort group names." + :type '(choice (const :tag "Don't sort" nil) + (const :tag "Sort alphabetically" string<) + (function :tag "Custom function")) + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + (force-mode-line-update)) + :group 'tab-line + :version "30.1") (defvar tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups "How to group various major modes together in the tab line. @@ -395,16 +444,28 @@ If the major mode's name matches REGEXP, it belongs to GROUPNAME. The default is for each major mode to have a separate group named the same as the mode.") +(defun tab-line-tabs-buffer-group-by-mode (&optional buffer) + "Group tab buffers by major mode." + (let ((mode (if buffer (with-current-buffer buffer + (format-mode-line mode-name)) + (format-mode-line mode-name)))) + (or (cdr (seq-find (lambda (group) + (string-match-p (car group) mode)) + tab-line-tabs-buffer-groups)) + mode))) + +(declare-function project-name "project" (project)) +(defun tab-line-tabs-buffer-group-by-project (&optional buffer) + "Group tab buffers by project name." + (with-current-buffer buffer + (if-let ((project (project-current))) + (project-name project) + "No project"))) + (defun tab-line-tabs-buffer-group-name (&optional buffer) (if (functionp tab-line-tabs-buffer-group-function) (funcall tab-line-tabs-buffer-group-function buffer) - (let ((mode (if buffer (with-current-buffer buffer - (format-mode-line mode-name)) - (format-mode-line mode-name)))) - (or (cdr (seq-find (lambda (group) - (string-match-p (car group) mode)) - tab-line-tabs-buffer-groups)) - mode)))) + (tab-line-tabs-buffer-group-by-mode buffer))) (defun tab-line-tabs-buffer-groups () "Return a list of tabs that should be displayed in the tab line. @@ -414,13 +475,14 @@ If non-nil, `tab-line-tabs-buffer-group-function' is used to generate the group name." (if (window-parameter nil 'tab-line-groups) (let* ((buffers (funcall tab-line-tabs-buffer-list-function)) - (groups - (seq-sort tab-line-tabs-buffer-groups-sort-function - (delq nil (mapcar #'car (seq-group-by - (lambda (buffer) - (tab-line-tabs-buffer-group-name - buffer)) - buffers))))) + (groups (delq nil + (mapcar #'car + (seq-group-by #'tab-line-tabs-buffer-group-name + buffers)))) + (sorted-groups (if (functionp tab-line-tabs-buffer-groups-sort-function) + (seq-sort tab-line-tabs-buffer-groups-sort-function + groups) + groups)) (selected-group (window-parameter nil 'tab-line-group)) (tabs (mapcar (lambda (group) @@ -431,12 +493,11 @@ generate the group name." (set-window-parameter nil 'tab-line-groups nil) (set-window-parameter nil 'tab-line-group group) (set-window-parameter nil 'tab-line-hscroll nil))))) - groups))) + sorted-groups))) tabs) - (let* ((window-parameter (window-parameter nil 'tab-line-group)) (group-name (tab-line-tabs-buffer-group-name (current-buffer))) - (group (prog1 (or window-parameter group-name "All") + (group (prog1 (or window-parameter group-name "No group") (when (equal window-parameter group-name) (set-window-parameter nil 'tab-line-group nil)))) (group-tab `(tab @@ -446,10 +507,9 @@ generate the group name." (set-window-parameter nil 'tab-line-groups t) (set-window-parameter nil 'tab-line-group group) (set-window-parameter nil 'tab-line-hscroll nil))))) - (buffers - (seq-filter (lambda (b) - (equal (tab-line-tabs-buffer-group-name b) group)) - (funcall tab-line-tabs-buffer-list-function))) + (buffers (seq-filter (lambda (b) + (equal (tab-line-tabs-buffer-group-name b) group)) + (funcall tab-line-tabs-buffer-list-function))) (sorted-buffers (if (functionp tab-line-tabs-buffer-group-sort-function) (seq-sort tab-line-tabs-buffer-group-sort-function buffers) @@ -486,6 +546,21 @@ variable `tab-line-tabs-function'." (list buffer) next-buffers))) +(defun tab-line-tabs-fixed-window-buffers () + "Like `tab-line-tabs-window-buffers' but keep stable sorting order. +This means that switching to a buffer previously shown in the same +window will keep the same order of tabs that was before switching. +And newly displayed buffers are added to the end of the tab line." + (let* ((old-buffers (window-parameter nil 'tab-line-buffers)) + (new-buffers (sort (tab-line-tabs-window-buffers) + :key (lambda (buffer) + (or (seq-position old-buffers buffer) + most-positive-fixnum))))) + (set-window-parameter nil 'tab-line-buffers new-buffers) + new-buffers)) + +(add-to-list 'window-persistent-parameters '(tab-line-buffers . t)) + (defcustom tab-line-tab-name-format-function #'tab-line-tab-name-format-default "Function to format a tab name. @@ -570,7 +645,7 @@ This is used by `tab-line-format'." tab-line-right-button))) (if hscroll (nthcdr (truncate hscroll) strings) strings) (list separator) - (when (and (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) + (when (and (memq tab-line-tabs-function tab-line-new-button-functions) tab-line-new-button-show tab-line-new-button) (list tab-line-new-button))))) @@ -814,28 +889,27 @@ using the `previous-buffer' command." (force-mode-line-update)))))))) (defun tab-line-select-tab-buffer (buffer &optional window) - (let* ((window-buffer (window-buffer window)) - (next-buffers (seq-remove (lambda (b) (eq b window-buffer)) - (window-next-buffers window))) - (prev-buffers (seq-remove (lambda (b) (eq b window-buffer)) - (mapcar #'car (window-prev-buffers window)))) - ;; Remove next-buffers from prev-buffers - (prev-buffers (seq-difference prev-buffers next-buffers))) - (cond - ((and (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) - (memq buffer next-buffers)) - (dotimes (_ (1+ (seq-position next-buffers buffer))) - (switch-to-next-buffer window))) - ((and (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) - (memq buffer prev-buffers)) - (dotimes (_ (1+ (seq-position prev-buffers buffer))) - (switch-to-prev-buffer window))) - (t - (with-selected-window window - (switch-to-buffer buffer)))))) - -(defcustom tab-line-switch-cycling nil - "Enable cycling tab switch. + (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) + (let* ((window-buffer (window-buffer window)) + (next-buffers (seq-remove (lambda (b) (eq b window-buffer)) + (window-next-buffers window))) + (prev-buffers (seq-remove (lambda (b) (eq b window-buffer)) + (mapcar #'car (window-prev-buffers window)))) + ;; Remove next-buffers from prev-buffers + (prev-buffers (seq-difference prev-buffers next-buffers))) + (cond + ((memq buffer next-buffers) + (dotimes (_ (1+ (seq-position next-buffers buffer))) + (switch-to-next-buffer window))) + ((memq buffer prev-buffers) + (dotimes (_ (1+ (seq-position prev-buffers buffer))) + (switch-to-prev-buffer window))))) + (with-selected-window window + (let ((switch-to-buffer-obey-display-actions nil)) + (switch-to-buffer buffer))))) + +(defcustom tab-line-switch-cycling t + "Wrap tabs on tab switch while cycling. If non-nil, `tab-line-switch-to-prev-tab' in the first tab switches to the last tab and `tab-line-switch-to-next-tab' in the last tab switches to the first tab. This variable is not consulted @@ -844,57 +918,90 @@ when `tab-line-tabs-function' is `tab-line-tabs-window-buffers'." :group 'tab-line :version "28.1") -(defun tab-line-switch-to-prev-tab (&optional event) - "Switch to the previous tab's buffer. -Its effect is the same as using the `previous-buffer' command -(\\[previous-buffer])." - (interactive (list last-nonmenu-event)) +(defun tab-line-switch-to-prev-tab (&optional event arg) + "Switch to the ARGth previous tab's buffer. +When `tab-line-tabs-function' is `tab-line-tabs-window-buffers', +its effect is the same as using the `previous-buffer' command +\(\\[previous-buffer]). +For other values of `tab-line-tabs-function' this command +switches to the previous buffer in the sequence defined by +`tab-line-tabs-function'. To wrap buffer cycling in this case +is possible when `tab-line-switch-cycling' is non-nil." + (interactive (list last-nonmenu-event + (prefix-numeric-value current-prefix-arg))) (let ((window (and (listp event) (posn-window (event-start event))))) - (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) - (switch-to-prev-buffer window) - (with-selected-window (or window (selected-window)) - (let* ((tabs (seq-filter - (lambda (tab) (or (bufferp tab) (assq 'buffer tab))) - (funcall tab-line-tabs-function))) - (pos (seq-position - tabs (current-buffer) - (lambda (tab buffer) - (if (bufferp tab) - (eq buffer tab) - (eq buffer (cdr (assq 'buffer tab))))))) - (tab (if pos - (if (and tab-line-switch-cycling (<= pos 0)) - (nth (1- (length tabs)) tabs) - (nth (1- pos) tabs)))) - (buffer (if (bufferp tab) tab (cdr (assq 'buffer tab))))) + (with-selected-window (or window (selected-window)) + (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) + (previous-buffer arg t) + (let* ((buffers (seq-keep + (lambda (tab) (or (and (bufferp tab) tab) + (alist-get 'buffer tab))) + (funcall tab-line-tabs-function))) + (old-pos (seq-position buffers (current-buffer))) + (new-pos (when old-pos (- old-pos (or arg 1)))) + (new-pos (when new-pos + (if tab-line-switch-cycling + (mod new-pos (length buffers)) + (max new-pos 0)))) + (buffer (when new-pos (nth new-pos buffers)))) (when (bufferp buffer) - (switch-to-buffer buffer))))))) - -(defun tab-line-switch-to-next-tab (&optional event) - "Switch to the next tab's buffer. -Its effect is the same as using the `next-buffer' command -(\\[next-buffer])." - (interactive (list last-nonmenu-event)) + (let ((switch-to-buffer-obey-display-actions nil)) + (switch-to-buffer buffer)))))))) + +(defun tab-line-switch-to-next-tab (&optional event arg) + "Switch to the next ARGth tab's buffer. +When `tab-line-tabs-function' is `tab-line-tabs-window-buffers', +its effect is the same as using the `next-buffer' command +\(\\[next-buffer]). +For other values of `tab-line-tabs-function' this command +switches to the next buffer in the sequence defined by +`tab-line-tabs-function'. To wrap buffer cycling in this case +is possible when `tab-line-switch-cycling' is non-nil." + (interactive (list last-nonmenu-event + (prefix-numeric-value current-prefix-arg))) (let ((window (and (listp event) (posn-window (event-start event))))) - (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) - (switch-to-next-buffer window) - (with-selected-window (or window (selected-window)) - (let* ((tabs (seq-filter - (lambda (tab) (or (bufferp tab) (assq 'buffer tab))) - (funcall tab-line-tabs-function))) - (pos (seq-position - tabs (current-buffer) - (lambda (tab buffer) - (if (bufferp tab) - (eq buffer tab) - (eq buffer (cdr (assq 'buffer tab))))))) - (tab (if pos - (if (and tab-line-switch-cycling (<= (length tabs) (1+ pos))) - (car tabs) - (nth (1+ pos) tabs)))) - (buffer (if (bufferp tab) tab (cdr (assq 'buffer tab))))) + (with-selected-window (or window (selected-window)) + (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) + (next-buffer arg t) + (let* ((buffers (seq-keep + (lambda (tab) (or (and (bufferp tab) tab) + (alist-get 'buffer tab))) + (funcall tab-line-tabs-function))) + (old-pos (seq-position buffers (current-buffer))) + (new-pos (when old-pos (+ old-pos (or arg 1)))) + (new-pos (when new-pos + (if tab-line-switch-cycling + (mod new-pos (length buffers)) + (min new-pos (1- (length buffers)))))) + (buffer (when new-pos (nth new-pos buffers)))) (when (bufferp buffer) - (switch-to-buffer buffer))))))) + (let ((switch-to-buffer-obey-display-actions nil)) + (switch-to-buffer buffer)))))))) + +(defun tab-line-mouse-move-tab (event) + "Move a tab to a different position on the tab line. +This command should be bound to a drag event. It moves the tab +at the mouse-down event to the position at mouse-up event. +It can be used only when `tab-line-tabs-function' is +customized to `tab-line-tabs-fixed-window-buffers'." + (interactive "e") + (when (eq tab-line-tabs-function #'tab-line-tabs-fixed-window-buffers) + (let* ((posnp1 (tab-line-event-start event)) + (posnp2 (event-end event)) + (string1 (car (posn-string posnp1))) + (string2 (car (posn-string posnp2))) + (buffer1 (when string1 (tab-line--get-tab-property 'tab string1))) + (buffer2 (when string2 (tab-line--get-tab-property 'tab string2))) + (window1 (posn-window posnp1)) + (window2 (posn-window posnp2)) + (buffers (window-parameter window1 'tab-line-buffers)) + (pos2 (when buffer2 (seq-position buffers buffer2)))) + (when (and (eq window1 window2) buffer1 pos2) + (setq buffers (delq buffer1 buffers)) + (cl-pushnew buffer1 (nthcdr pos2 buffers)) + (set-window-parameter window1 'tab-line-buffers buffers) + (set-window-parameter window1 'tab-line-cache nil) + (with-selected-window window1 (force-mode-line-update)))))) (defcustom tab-line-close-tab-function 'bury-buffer @@ -904,7 +1011,7 @@ buffers, which effectively hides the buffer's tab from the tab line. If `kill-buffer', kills the tab's buffer. When a function, it is called with the tab as its argument. This option is useful when `tab-line-tabs-function' has the value -`tab-line-tabs-window-buffers'." +`tab-line-tabs-window-buffers' or `tab-line-tabs-fixed-window-buffers'." :type '(choice (const :tag "Bury buffer" bury-buffer) (const :tag "Kill buffer" kill-buffer) (function :tag "Function")) @@ -997,6 +1104,19 @@ However, return the correct mouse position list if EVENT is a (event-start event))) +(defvar-keymap tab-line-mode-map + :doc "Keymap for keys of `tab-line-mode'." + "C-x <left>" #'tab-line-switch-to-prev-tab + "C-x C-<left>" #'tab-line-switch-to-prev-tab + "C-x <right>" #'tab-line-switch-to-next-tab + "C-x C-<right>" #'tab-line-switch-to-next-tab) + +(defvar-keymap tab-line-switch-repeat-map + :doc "Keymap to repeat tab/buffer cycling. Used in `repeat-mode'." + :repeat t + "<left>" #'tab-line-switch-to-prev-tab + "<right>" #'tab-line-switch-to-next-tab) + ;;;###autoload (define-minor-mode tab-line-mode "Toggle display of tab line in the windows displaying the current buffer." @@ -1044,6 +1164,7 @@ of `tab-line-exclude', are exempt from `tab-line-mode'." (global-set-key [tab-line down-mouse-3] 'tab-line-context-menu) +(global-set-key [tab-line drag-mouse-1] 'tab-line-mouse-move-tab) (global-set-key [tab-line mouse-4] 'tab-line-hscroll-left) (global-set-key [tab-line mouse-5] 'tab-line-hscroll-right) diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index 6512ef81ff7..3538f41aa84 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -532,7 +532,7 @@ accessible to other programs." ;; Coding systems used by androidvfs.c. (define-ccl-program android-encode-jni - `(2 ((loop + '(2 ((loop (read r0) (if (r0 < #x1) ; 0x0 is encoded specially in JNI environments. ((write #xc0) @@ -564,7 +564,7 @@ accessible to other programs." "Encode characters from the input buffer for Java virtual machines.") (define-ccl-program android-decode-jni - `(1 ((loop + '(1 ((loop ((read-if (r0 >= #x80) ; More than a one-byte sequence? ((if (r0 < #xe0) ;; Two-byte sequence; potentially a NULL diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 9b696475c34..3c0acf368f4 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -288,7 +288,6 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(libxml2 "libxml2-2.dll" "libxml2.dll") '(zlib "zlib1.dll" "libz-1.dll") '(lcms2 "liblcms2-2.dll") - '(json "libjansson-4.dll") '(gccjit "libgccjit-0.dll") ;; MSYS2 distributes libtree-sitter.dll, without API version ;; number... diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el index 5e1636033f6..e74409128df 100644 --- a/lisp/textmodes/conf-mode.el +++ b/lisp/textmodes/conf-mode.el @@ -613,27 +613,26 @@ For details see `conf-mode'. Example: "Font-lock helper function for `conf-toml-mode'. Handles recognizing TOML section names, like [section], \[[section]], or [something.\"else\".section]." - (save-excursion - ;; Skip any number of "[" to handle things like [[section]]. - (when (re-search-forward "^\\s-*\\[+" limit t) - (let ((start (point))) - (backward-char) - (let ((end (min limit - (condition-case nil - (progn - (forward-list) - (1- (point))) - (scan-error - (end-of-line) - (point)))))) - ;; If there is a comma in the text, then we assume this is - ;; an array and not a section. (This could be refined to - ;; look only for unquoted commas if necessary.) - (save-excursion - (goto-char start) - (unless (search-forward "," end t) - (set-match-data (list start end)) - t))))))) + ;; Skip any number of "[" to handle things like [[section]]. + (when (re-search-forward "^\\s-*\\[+" limit t) + (let ((start (point))) + (backward-char) + (let ((end (min limit + (condition-case nil + (progn + (forward-list) + (1- (point))) + (scan-error + (end-of-line) + (point)))))) + ;; If there is a comma in the text, then we assume this is + ;; an array and not a section. (This could be refined to + ;; look only for unquoted commas if necessary.) + (save-excursion + (goto-char start) + (unless (search-forward "," end t) + (set-match-data (list start end)) + t)))))) ;;;###autoload (define-derived-mode conf-toml-mode conf-mode "Conf[TOML]" diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index 0b5c6756ab9..e2de6959dc6 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -359,7 +359,7 @@ the rules from `css-mode'." (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t) ;; This is sort of a prog-mode as well as a text mode. - (run-hooks 'prog-mode-hook)) + (run-mode-hooks 'prog-mode-hook)) (put 'mhtml-mode 'flyspell-mode-predicate #'mhtml--flyspell-check-word) diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el index f7b155874de..397b449a9c8 100644 --- a/lisp/textmodes/reftex-cite.el +++ b/lisp/textmodes/reftex-cite.el @@ -1048,7 +1048,14 @@ in order to only add another reference in the same cite command." ((= l ?E) (car (reftex-get-bib-names "editor" entry))) ((= l ?h) (reftex-get-bib-field "howpublished" entry)) ((= l ?i) (reftex-get-bib-field "institution" entry)) - ((= l ?j) (reftex-get-bib-field "journal" entry)) + ((= l ?j) (let ((jr (reftex-get-bib-field "journal" entry))) + (if (string-empty-p jr) + ;; Biblatex prefers the alternative + ;; journaltitle field, so check if that + ;; exists in case journal is empty + (reftex-get-bib-field "journaltitle" entry) + ;; Standard BibTeX + jr))) ((= l ?k) (reftex-get-bib-field "key" entry)) ((= l ?m) (reftex-get-bib-field "month" entry)) ((= l ?n) (reftex-get-bib-field "number" entry)) @@ -1144,8 +1151,6 @@ recommended for follow mode. It works OK for individual lookups." (defun reftex-all-used-citation-keys () "Return a list of all citation keys used in document." (reftex-access-scan-info) - ;; FIXME: multicites macros provided by biblatex - ;; are not covered in this function. (let ((files (reftex-all-document-files)) (re (concat "\\\\" "\\(?:" @@ -1170,6 +1175,25 @@ recommended for follow mode. It works OK for individual lookups." "\\)" ;; Now match the key: "{\\([^}]+\\)}")) + ;; Multicites: Match \MACRONAME(Global Pre)(Global Post) + (re2 (concat "\\\\" + (regexp-opt '("cites" "Cites" + "parencites" "Parencites" + "footcites" "footcitetexts" + "smartcites" "Smartcites" + "textcites" "Textcites" + "supercites" + "autocites" "Autocites" + "volcites" "Volcites" + "pvolcites" "Pvolcites" + "fvolcites" "Fvolcites" + "svolcites" "Svolcites" + "tvolcites" "Tvolcites" + "avolcites" "Avolcites")) + "\\(?:([^)]*)\\)\\{0,2\\}")) + ;; For each key in list [prenote][postnote]{key} + (re3 (concat "\\(?:\\[[^]]*\\]\\)\\{0,2\\}" + "{\\([^}]+\\)}")) file keys kk k) (save-current-buffer (while (setq file (pop files)) @@ -1188,7 +1212,29 @@ recommended for follow mode. It works OK for individual lookups." (setq kk (split-string kk "[, \t\r\n]+")) (while (setq k (pop kk)) (or (member k keys) - (setq keys (cons k keys)))))))))) + (setq keys (cons k keys)))))) + ;; And now search for citation lists: + (goto-char (point-min)) + (while (re-search-forward re2 nil t) + ;; Make sure we're not inside a comment: + (unless (save-match-data + (nth 4 (syntax-ppss))) + (while (progn + ;; Ignore the value of + ;; `reftex-allow-detached-macro-args' since we + ;; expect a bigger number of args and detaching + ;; them seems natural for line breaks: + (while (looking-at "[ \t\r\n]+\\|%.*\n") + (goto-char (match-end 0))) + (and (looking-at re3) + (goto-char (match-end 0)))) + (setq kk (match-string-no-properties 1)) + (while (string-match "%.*\n?" kk) + (setq kk (replace-match "" t t kk))) + (setq kk (split-string kk "[, \t\r\n]+")) + (while (setq k (pop kk)) + (or (member k keys) + (setq keys (cons k keys))))))))))) (reftex-kill-temporary-buffers) keys)) diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el index 2c5e5cb7ce6..c8ca054407c 100644 --- a/lisp/textmodes/reftex-dcr.el +++ b/lisp/textmodes/reftex-dcr.el @@ -241,9 +241,9 @@ With argument, actually select the window showing the cross reference." (reftex-view-crossref current-prefix-arg)) (defun reftex-view-crossref-when-idle () - ;; Display info about crossref at point in echo area or a window. - ;; This function was designed to work with an idle timer. - ;; We try to get out of here as quickly as possible if the call is useless. + "Display info about crossref at point in echo area or a window. +This function is designed to work with an idle timer and returns quickly +if the call is useless." (and reftex-mode ;; Make sure message area is free if we need it. (or (eq reftex-auto-view-crossref 'window) (not (current-message))) @@ -255,7 +255,15 @@ With argument, actually select the window showing the cross reference." (save-excursion (search-backward "\\" nil t) (looking-at "\\\\[a-zA-Z]*\\(cite\\|ref\\|bibentry\\)")) - + ;; Also check if point is inside a mandatory argument where the + ;; cite/ref key usually resides: (bug#38258) + (save-excursion + (condition-case nil + (let ((forward-sexp-function nil)) + (up-list -1) + (= (following-char) ?\{)) + (error nil))) + ;; Finally, call `reftex-view-crossref': (condition-case nil (let ((current-prefix-arg nil)) (cond diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el index 9694a1364d3..170d49be8c8 100644 --- a/lisp/textmodes/reftex-parse.el +++ b/lisp/textmodes/reftex-parse.el @@ -801,17 +801,17 @@ if the information is exact (t) or approximate (nil)." ) (defsubst reftex-move-to-previous-arg (&optional bound) - "Assuming that we are in front of a macro argument, -move backward to the closing parenthesis of the previous argument. -This function understands the splitting of macros over several lines -in TeX." + "Move backward to the closing parenthesis of the previous argument. +This happens under the assumption that we are in front of a macro +argument. This function understands the splitting of macros over +several lines in TeX." (cond ;; Just to be quick: - ((memq (preceding-char) '(?\] ?\}))) + ((memq (preceding-char) '(?\] ?\) ?\}))) ;; Do a search ((and reftex-allow-detached-macro-args (re-search-backward - "[]}][ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*\\=" bound t)) + "[])}][ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*\\=" bound t)) (goto-char (1+ (match-beginning 0))) t) (t nil))) @@ -860,13 +860,25 @@ considered an argument of macro \\macro." (while (and (reftex-move-to-previous-arg bound) (condition-case nil (let ((forward-sexp-function nil)) - (backward-sexp) t) + (if (eq (preceding-char) ?\)) + ;; '?\(' and '?\)' receive the + ;; punctuation syntax "." in + ;; `reftex-syntax-table', so we have + ;; to change it in order move back + ;; over the optional arg in + ;; parentheses correctly: + (let ((temp-table (make-syntax-table))) + (modify-syntax-entry ?\( "()" temp-table) + (modify-syntax-entry ?\) ")(" temp-table) + (with-syntax-table temp-table + (backward-sexp))) + (backward-sexp)) + t) (error nil))) - (if (eq (following-char) ?\[) (cl-incf cnt-opt)) + (if (memq (following-char) '(?\( ?\[)) (cl-incf cnt-opt)) (cl-incf cnt)) (setq pos (point)) - (when (and (or (= (following-char) ?\[) - (= (following-char) ?\{)) + (when (and (memq (following-char) '(?\[ ?\( ?\{)) (re-search-backward "\\\\[*a-zA-Z]+\\=" nil t)) (setq cmd (reftex-match-string 0)) (when (looking-at "\\\\begin{[^}]*}") diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 02ee1242c72..97c950267c6 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2035,7 +2035,8 @@ In the tex shell buffer this command behaves like `comint-send-input'." (defun tex-display-shell () "Make the TeX shell buffer visible in a window." - (display-buffer (tex-shell-buf) display-tex-shell-buffer-action) + (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) + (display-buffer (tex-shell-buf) display-tex-shell-buffer-action)) (tex-recenter-output-buffer nil)) (defun tex-shell-sentinel (proc _msg) @@ -2692,7 +2693,8 @@ line LINE of the window, or centered if LINE is nil." (if (null tex-shell) (message "No TeX output buffer") (when-let ((window - (display-buffer tex-shell display-tex-shell-buffer-action))) + (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) + (display-buffer tex-shell display-tex-shell-buffer-action)))) (with-selected-window window (bury-buffer tex-shell) (goto-char (point-max)) diff --git a/lisp/time.el b/lisp/time.el index a8d3ab9c813..b6f8de8fc4a 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -459,7 +459,11 @@ Each element has the form (TIMEZONE LABEL). TIMEZONE should be a string of the form AREA/LOCATION, where AREA is the name of a region -- a continent or ocean, and LOCATION is the name of a specific location, e.g., a city, within that region. -LABEL is a string to display as the label of that TIMEZONE's time." +LABEL is a string to display as the label of that TIMEZONE's time. + +This option has effect only on systems that support Posix-style +zoneinfo files specified as CONTINENT/CITY. In particular, +MS-Windows doesn't support that; use `legacy-style-world-list' instead." :type '(repeat (list string string)) :version "23.1") @@ -478,7 +482,10 @@ TIMEZONE should be a string of the form: See the documentation of the TZ environment variable on your system, for more details about the format of TIMEZONE. -LABEL is a string to display as the label of that TIMEZONE's time." +LABEL is a string to display as the label of that TIMEZONE's time + +This is the only option that has effect on MS-Windows, where you also +cannot specify the [offset][,date[/time],date[/time]] part." :type '(repeat (list string string)) :version "23.1") diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el index 96b61c7b229..0f645338674 100644 --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@ -360,11 +360,12 @@ holds a keymap." (if (featurep 'move-toolbar) (defcustom tool-bar-position 'top "Specify on which side the tool bar shall be. -Possible values are `top' (tool bar on top), `bottom' (tool bar at bottom), -`left' (tool bar on left) and `right' (tool bar on right). -This option has effect only on graphical frames and only -if Emacs was built with GTK. -Customize `tool-bar-mode' if you want to show or hide the tool bar." +Possible values are `top' (tool bar on top), `bottom' (tool bar at +bottom), `left' (tool bar on left) and `right' (tool bar on right). +This option takes effect only on graphical frames, the values `left' and +`right' only if Emacs was built with GTK, and `bottom' only on systems +besides Nextstep. Customize `tool-bar-mode' if you want to show or hide +the tool bar." :version "24.1" :type '(choice (const top) (const bottom) diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 4537fdf8087..6c2fe36ed9d 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -178,7 +178,7 @@ rest are not called.") "Return the buffer over which event EVENT occurred. This might return nil if the event did not occur over a buffer." (let ((window (posn-window (event-end event)))) - (and window (window-buffer window)))) + (and (windowp window) (window-buffer window)))) ;;; Timeout for tooltip display diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index c8de1d8ee31..ca02ca3caf6 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -154,6 +154,17 @@ selected.") Used in an attempt to keep this word selected during later dragging.") +;; Should this variable be documented? +(defvar-local touch-screen-keyboard-function nil + "Function that decides whether to display the on screen keyboard. +If set, this function is called with point set to the position of the +tap involved when a command listed in `touch-screen-set-point-commands' +is about to be invoked in response to a tap, the current buffer, or the +text beneath point (in the case of an `inhibit-read-only' text +property), is not read only, and `touch-screen-display-keyboard' is nil, +and should return non-nil if it is appropriate to display the on-screen +keyboard afterwards.") + ;;; Scroll gesture. @@ -351,7 +362,8 @@ word around EVENT; otherwise, set point to the location of EVENT." touch-screen-word-select-bounds nil) (push-mark point) (goto-char point) - (activate-mark)) + (activate-mark) + (setq deactivate-mark nil)) ;; Start word selection by trying to obtain the position ;; around point. (let ((word-start nil) @@ -381,7 +393,8 @@ word around EVENT; otherwise, set point to the location of EVENT." touch-screen-word-select-initial-word nil) (push-mark point) (goto-char point) - (activate-mark)) + (activate-mark) + (setq deactivate-mark nil)) ;; Otherwise, select the word. Move point to either the ;; end or the start of the word, depending on which is ;; closer to EVENT. @@ -420,10 +433,12 @@ word around EVENT; otherwise, set point to the location of EVENT." (progn (push-mark word-start) (activate-mark) + (setq deactivate-mark nil) (goto-char word-end)) (progn (push-mark word-end) (activate-mark) + (setq deactivate-mark nil) (goto-char word-start))) ;; Record the bounds of the selected word. (setq touch-screen-word-select-bounds @@ -837,7 +852,8 @@ area." ;; Display a preview of the line now around ;; point if requested by the user. (when touch-screen-preview-select - (touch-screen-preview-select)))))))))))))) + (touch-screen-preview-select))))))))))) + (setq deactivate-mark nil)))) (defun touch-screen-restart-drag (event) "Restart dragging to select text. @@ -1254,17 +1270,20 @@ response to the minibuffer being closed." (cancel-timer minibuffer-on-screen-keyboard-timer) (setq minibuffer-on-screen-keyboard-timer nil))))) -(defun touch-screen-handle-point-up (point prefix) +(defun touch-screen-handle-point-up (point prefix canceled) "Notice that POINT has been removed from the screen. POINT should be the point currently tracked as `touch-screen-current-tool'. PREFIX should be a virtual function key used to look up key bindings. +CANCELED should indicate whether the touch point was removed by +window-system intervention rather than user action. If an ancillary touch point is being observed, transfer touch information from `touch-screen-aux-tool' to -`touch-screen-current-tool' and set it to nil, thereby resuming -gesture recognition with that tool replacing the tool removed. +`touch-screen-current-tool' and set the former to nil, thereby +resuming gesture recognition with that tool replacing the tool +removed. Otherwise: @@ -1315,136 +1334,163 @@ is not read-only." ;; hasn't been moved, translate the sequence into a ;; regular mouse click. (eq what 'restart-drag)) - (when (windowp (posn-window posn)) - (setq point (posn-point posn) - window (posn-window posn)) - ;; Select the window that was tapped given that it - ;; isn't an inactive minibuffer window. - (when (or (not (eq window - (minibuffer-window - (window-frame window)))) - (minibuffer-window-active-p window)) - (select-window window)) - ;; Now simulate a mouse click there. If there is a - ;; link or a button, use mouse-2 to push it. - (let* ((event (list (if (or (mouse-on-link-p posn) - (and point (button-at point))) - 'mouse-2 - 'mouse-1) - posn)) - ;; Look for the command bound to this event. - (command (key-binding (if prefix - (vector prefix - (car event)) - (vector (car event))) - t nil posn))) - (deactivate-mark) - (when point - ;; This is necessary for following links. - (goto-char point)) - ;; Figure out if the on screen keyboard needs to be - ;; displayed. - (when command - (if (memq command touch-screen-set-point-commands) - (if touch-screen-translate-prompt - ;; Forgo displaying the virtual keyboard - ;; should touch-screen-translate-prompt be - ;; set, for then the key won't be delivered - ;; to the command loop, but rather to a - ;; caller of read-key-sequence such as - ;; describe-key. - (throw 'input-event event) - (if (and (or (not buffer-read-only) - touch-screen-display-keyboard) - ;; Detect the splash screen and - ;; avoid displaying the on screen - ;; keyboard there. - (not (equal (buffer-name) "*GNU Emacs*"))) - ;; Once the on-screen keyboard has been - ;; opened, add - ;; `touch-screen-window-selection-changed' - ;; as a window selection change function - ;; This then prevents it from being - ;; hidden after exiting the minibuffer. - (progn - (add-hook - 'window-selection-change-functions - #'touch-screen-window-selection-changed) - (frame-toggle-on-screen-keyboard - (selected-frame) nil)) - ;; Otherwise, hide the on screen keyboard - ;; now. - (frame-toggle-on-screen-keyboard (selected-frame) - t)) - ;; But if it's being called from `describe-key' - ;; or some such, return it as a key sequence. - (throw 'input-event event))) - ;; If not, return the event. - (throw 'input-event event))))) + ;; Don't attempt to execute commands bound to mouse events + ;; if the touch sequence has been canceled. + (unless canceled + (when (windowp (posn-window posn)) + (setq point (posn-point posn) + window (posn-window posn)) + ;; Select the window that was tapped given that it + ;; isn't an inactive minibuffer window. + (when (or (not (eq window + (minibuffer-window + (window-frame window)))) + (minibuffer-window-active-p window)) + (select-window window)) + ;; Now simulate a mouse click there. If there is a + ;; link or a button, use mouse-2 to push it. + (let* ((event (list (if (or (mouse-on-link-p posn) + (and point + (get-char-property + point 'button))) + 'mouse-2 + 'mouse-1) + posn)) + ;; Look for the command bound to this event. + (command (key-binding (if prefix + (vector prefix + (car event)) + (vector (car event))) + t nil posn))) + (deactivate-mark) + (when point + ;; This is necessary for following links. + (goto-char point)) + ;; Figure out if the on screen keyboard needs to be + ;; displayed. + (when command + (if (or (memq command touch-screen-set-point-commands) + ;; Users of packages that redefine + ;; `mouse-set-point', or other commands + ;; recognized as defining the point, should + ;; not find the on screen keyboard + ;; inaccessible even with + ;; `touch-screen-display-keyboard' enabled. + touch-screen-display-keyboard) + (if touch-screen-translate-prompt + ;; Forgo displaying the virtual keyboard + ;; should `touch-screen-translate-prompt' be + ;; set, for then the key won't be delivered + ;; to the command loop, but rather to a + ;; caller of `read-key-sequence' such as + ;; `describe-key'. + (throw 'input-event event) + (if (or touch-screen-display-keyboard + (and (or (not buffer-read-only) + inhibit-read-only + ;; Display the on screen + ;; keyboard even if just the + ;; text under point is not + ;; read-only. + (get-text-property + point 'inhibit-read-only)) + ;; If the major mode has defined + ;; bespoke criteria for + ;; displaying the on screen + ;; keyboard, consult it here. + (or (not touch-screen-keyboard-function) + (funcall + touch-screen-keyboard-function)))) + ;; Once the on-screen keyboard has been + ;; opened, add + ;; `touch-screen-window-selection-changed' + ;; as a window selection change function + ;; This then prevents it from being + ;; hidden after exiting the minibuffer. + (progn + (add-hook + 'window-selection-change-functions + #'touch-screen-window-selection-changed) + (frame-toggle-on-screen-keyboard + (selected-frame) nil)) + ;; Otherwise, hide the on screen keyboard + ;; now. + (frame-toggle-on-screen-keyboard (selected-frame) + t)) + ;; But if it's being called from `describe-key' + ;; or some such, return it as a key sequence. + (throw 'input-event event))) + ;; If not, return the event. + (throw 'input-event event)))))) ((eq what 'mouse-drag) ;; Generate a corresponding `mouse-1' event. - (let* ((new-window (posn-window posn)) - (new-point (posn-point posn)) - (old-posn (nth 4 touch-screen-current-tool)) - (old-window (posn-window posn)) - (old-point (posn-point posn))) - (throw 'input-event - ;; If the position of the touch point hasn't - ;; changed, or it doesn't start or end on a - ;; window... - (if (and (not old-point) (not new-point)) - ;; Should old-point and new-point both equal - ;; nil, compare the posn areas and nominal - ;; column position. If either are - ;; different, generate a drag event. - (let ((new-col-row (posn-col-row posn)) - (new-area (posn-area posn)) - (old-col-row (posn-col-row old-posn)) - (old-area (posn-area old-posn))) - (if (and (equal new-col-row old-col-row) - (eq new-area old-area)) - ;; ... generate a mouse-1 event... - (list 'mouse-1 posn) - ;; ... otherwise, generate a - ;; drag-mouse-1 event. - (list 'drag-mouse-1 old-posn posn))) - (if (and (eq new-window old-window) - (eq new-point old-point) - (windowp new-window) - (windowp old-window)) - ;; ... generate a mouse-1 event... - (list 'mouse-1 posn) - ;; ... otherwise, generate a drag-mouse-1 - ;; event. - (list 'drag-mouse-1 old-posn posn)))))) + ;; Alternatively, quit if the touch sequence was canceled. + (if canceled + (keyboard-quit) + (let* ((new-window (posn-window posn)) + (new-point (posn-point posn)) + (old-posn (nth 4 touch-screen-current-tool)) + (old-window (posn-window posn)) + (old-point (posn-point posn))) + (throw 'input-event + ;; If the position of the touch point hasn't + ;; changed, or it doesn't start or end on a + ;; window... + (if (and (not old-point) (not new-point)) + ;; Should old-point and new-point both equal + ;; nil, compare the posn areas and nominal + ;; column position. If either are + ;; different, generate a drag event. + (let ((new-col-row (posn-col-row posn)) + (new-area (posn-area posn)) + (old-col-row (posn-col-row old-posn)) + (old-area (posn-area old-posn))) + (if (and (equal new-col-row old-col-row) + (eq new-area old-area)) + ;; ... generate a mouse-1 event... + (list 'mouse-1 posn) + ;; ... otherwise, generate a + ;; drag-mouse-1 event. + (list 'drag-mouse-1 old-posn posn))) + (if (and (eq new-window old-window) + (eq new-point old-point) + (windowp new-window) + (windowp old-window)) + ;; ... generate a mouse-1 event... + (list 'mouse-1 posn) + ;; ... otherwise, generate a drag-mouse-1 + ;; event. + (list 'drag-mouse-1 old-posn posn))))))) ((eq what 'mouse-1-menu) ;; Generate a `down-mouse-1' event at the position the tap - ;; took place. - (throw 'input-event - (list 'down-mouse-1 - (nth 4 touch-screen-current-tool)))) + ;; took place, unless the touch sequence was canceled. + (unless canceled + (throw 'input-event + (list 'down-mouse-1 + (nth 4 touch-screen-current-tool))))) ((or (eq what 'drag) ;; Merely initiating a drag is sufficient to select a ;; word if word selection is enabled. (eq what 'held)) - ;; Display the on screen keyboard if the region is now - ;; active. Check this within the window where the tool - ;; was first place. - (setq window (nth 1 touch-screen-current-tool)) - (when window - (with-selected-window window - (when (and (region-active-p) - (not buffer-read-only)) - ;; Once the on-screen keyboard has been opened, add - ;; `touch-screen-window-selection-changed' as a - ;; window selection change function. This then - ;; prevents it from being hidden after exiting the - ;; minibuffer. - (progn - (add-hook 'window-selection-change-functions - #'touch-screen-window-selection-changed) - (frame-toggle-on-screen-keyboard (selected-frame) - nil)))))))))) + (unless canceled + ;; Display the on screen keyboard if the region is now + ;; active. Check this within the window where the tool + ;; was first place. + (setq window (nth 1 touch-screen-current-tool)) + (when window + (with-selected-window window + (when (and (region-active-p) + (not buffer-read-only)) + ;; Once the on-screen keyboard has been opened, add + ;; `touch-screen-window-selection-changed' as a + ;; window selection change function. This then + ;; prevents it from being hidden after exiting the + ;; minibuffer. + (progn + (add-hook 'window-selection-change-functions + #'touch-screen-window-selection-changed) + (frame-toggle-on-screen-keyboard (selected-frame) + nil))))))))))) (defun touch-screen-handle-touch (event prefix &optional interactive) "Handle a single touch EVENT, and perform associated actions. @@ -1684,16 +1730,12 @@ functions undertaking event management themselves to call (setq touch-screen-current-timer nil)) (let ((old-aux-tool touch-screen-aux-tool)) (unwind-protect - ;; Don't perform any actions associated with releasing the - ;; tool if the touch sequence was intercepted by another - ;; program. - (if (caddr event) - (setq touch-screen-current-tool nil) - (touch-screen-handle-point-up (cadr event) prefix)) + (touch-screen-handle-point-up (cadr event) prefix + (caddr event)) ;; If an ancillary tool is present the function call above - ;; will merely transfer information from it into the current - ;; tool list, thereby rendering it the new current tool, - ;; until such time as it too is released. + ;; will simply transfer information from it into the current + ;; tool list, rendering the new current tool, until such + ;; time as it too is released. (when (not (and old-aux-tool (not touch-screen-aux-tool))) ;; Make sure the tool list is cleared even if ;; `touch-screen-handle-point-up' throws. diff --git a/lisp/treesit.el b/lisp/treesit.el index 2b4893e6129..86ed1bbae33 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -61,6 +61,7 @@ (declare-function treesit-parser-set-included-ranges "treesit.c") (declare-function treesit-parser-included-ranges "treesit.c") +(declare-function treesit-parser-changed-ranges "treesit.c") (declare-function treesit-parser-add-notifier "treesit.c") (declare-function treesit-node-type "treesit.c") @@ -816,6 +817,17 @@ OVERRIDE is the override flag for this query. Its value can be t, nil, append, prepend, keep. See more in `treesit-font-lock-rules'.") +(defsubst treesit--font-lock-setting-feature (setting) + "Reutrn the feature of SETTING. +SETTING should be a setting in `treesit-font-lock-settings'." + (nth 2 setting)) + +(defsubst treesit--font-lock-setting-enable (setting) + "Return enabled SETTING." + (let ((new-setting (copy-tree setting))) + (setf (nth 1 new-setting) t) + new-setting)) + (defun treesit--font-lock-level-setter (sym val) "Custom setter for `treesit-font-lock-level'. Set the default value of SYM to VAL, recompute fontification @@ -1094,6 +1106,43 @@ and leave settings for other languages unchanged." ((memq feature remove-list) nil) (t current-value)))))) +(defun treesit-add-font-lock-rules (rules &optional how feature) + "Add font-lock RULES to the current buffer + +RULES should be the return value of `treesit-font-lock-rules'. RULES +will be enabled and added to `treesit-font-lock-settings'. + +HOW can be either :before or :after. If HOW is :before, prepend RULES +before all other existing font-lock rules in +`treesit-font-lock-settings'; if :after or omitted, append RULES after +all existing rules. + +If FEATURE is non-nil, add RULES before/after rules for FEATURE. See +docstring of `treesit-font-lock-rules' for what is a feature." + (let ((rules (seq-map #'treesit--font-lock-setting-enable rules)) + (feature-idx + (when feature + (cl-position-if + (lambda (setting) + (eq (treesit--font-lock-setting-feature setting) feature)) + treesit-font-lock-settings)))) + (pcase (cons how feature) + ((or '(:after . nil) '(nil . nil)) + (setq treesit-font-lock-settings + (append treesit-font-lock-settings rules))) + ('(:before . nil) + (setq treesit-font-lock-settings + (append rules treesit-font-lock-settings))) + (`(:after . ,_feature) + (setf (nthcdr (1+ feature-idx) treesit-font-lock-settings) + (append rules + (nthcdr (1+ feature-idx) + treesit-font-lock-settings)))) + (`(:before . ,_feature) + (setf (nthcdr feature-idx treesit-font-lock-settings) + (append rules + (nthcdr feature-idx treesit-font-lock-settings))))))) + (defun treesit-fontify-with-override (start end face override &optional bound-start bound-end) "Apply FACE to the region between START and END. @@ -1328,18 +1377,6 @@ non-nil, print debugging information." (max node-start start) (min node-end end) face (treesit-node-type node))))))))) -(defun treesit--font-lock-notifier (ranges parser) - "Ensures updated parts of the parse-tree are refontified. -RANGES is a list of (BEG . END) ranges, PARSER is the tree-sitter -parser notifying of the change." - (with-current-buffer (treesit-parser-buffer parser) - (dolist (range ranges) - (when treesit--font-lock-verbose - (message "Notifier received range: %s-%s" - (car range) (cdr range))) - (with-silent-modifications - (put-text-property (car range) (cdr range) 'fontified nil))))) - (defvar-local treesit--syntax-propertize-start nil "If non-nil, next `syntax-propertize' should start at this position. @@ -1348,20 +1385,6 @@ When tree-sitter parser reparses, it calls and that function sets this variable to the start of the affected region.") -(defun treesit--syntax-propertize-notifier (ranges parser) - "Sets `treesit--syntax-propertize-start' to the smallest start. -Specifically, the smallest start position among all the ranges in -RANGES for PARSER." - (with-current-buffer (treesit-parser-buffer parser) - (when-let* ((range-starts (mapcar #'car ranges)) - (min-range-start - (seq-reduce - #'min (cdr range-starts) (car range-starts)))) - (if (null treesit--syntax-propertize-start) - (setq treesit--syntax-propertize-start min-range-start) - (setq treesit--syntax-propertize-start - (min treesit--syntax-propertize-start min-range-start)))))) - (defvar-local treesit--pre-redisplay-tick nil "The last `buffer-chars-modified-tick' that we've processed. Because `pre-redisplay-functions' could be called multiple times @@ -1369,32 +1392,47 @@ during a single command loop, we use this variable to debounce calls to `treesit--pre-redisplay'.") (defun treesit--pre-redisplay (&rest _) - "Force reparse and consequently run all notifiers. - -One of the notifiers is `treesit--font-lock-notifier', which will -mark the region whose syntax has changed to \"need to refontify\". - -For example, when the user types the final slash of a C block -comment /* xxx */, not only do we need to fontify the slash, but -also the whole block comment, which previously wasn't fontified -as comment due to incomplete parse tree." + "Force a reparse on the primary parser and do some work. + +After the parser reparses, we get the changed ranges, and +1) update non-primary parsers' ranges in the changed ranges +2) mark these ranges as to-be-fontified, +3) tell syntax-ppss to start reparsing from the min point of the ranges + +We need to mark to-be-fontified ranges before redisplay starts working, +because sometimes the range edited by the user is not the only range +that needs to be refontified. For example, when the user types the +final slash of a C block comment /* xxx */, not only do we need to +fontify the slash, but also the whole block comment, which previously +wasn't fontified as comment due to incomplete parse tree." (unless (eq treesit--pre-redisplay-tick (buffer-chars-modified-tick)) - ;; `treesit-update-ranges' will force the host language's parser to - ;; reparse and set correct ranges for embedded parsers. Then - ;; `treesit-parser-root-node' will force those parsers to reparse. - (let ((len (+ (* (window-body-height) (window-body-width)) 800))) - ;; FIXME: As a temporary fix, this prevents Emacs from updating - ;; every single local parsers in the buffer every time there's an - ;; edit. Moving forward, we need some way to properly track the - ;; regions which need update on parser ranges, like what jit-lock - ;; and syntax-ppss does. - (treesit-update-ranges - (max (point-min) (- (point) len)) - (min (point-max) (+ (point) len)))) - ;; Force repase on _all_ the parsers might not be necessary, but - ;; this is probably the most robust way. - (dolist (parser (treesit-parser-list)) - (treesit-parser-root-node parser)) + (let ((primary-parser + ;; TODO: We need something less ugly than this for getting + ;; the primary parser/language. + (if treesit-range-settings + (let ((query (car (car treesit-range-settings)))) + (if (treesit-query-p query) + (treesit-parser-create + (treesit-query-language query)) + (car (treesit-parser-list)))) + (car (treesit-parser-list))))) + ;; Force a reparse on the primary parser. + (treesit-parser-root-node primary-parser) + (dolist (range (treesit-parser-changed-ranges primary-parser)) + ;; 1. Update ranges. + (treesit-update-ranges (car range) (cdr range)) + ;; 2. Mark the changed ranges to be fontified. + (when treesit--font-lock-verbose + (message "Notifier received range: %s-%s" + (car range) (cdr range))) + (with-silent-modifications + (put-text-property (car range) (cdr range) 'fontified nil)) + ;; 3. Set `treesit--syntax-propertize-start'. + (if (null treesit--syntax-propertize-start) + (setq treesit--syntax-propertize-start (car range)) + (setq treesit--syntax-propertize-start + (min treesit--syntax-propertize-start (car range)))))) + (setq treesit--pre-redisplay-tick (buffer-chars-modified-tick)))) (defun treesit--pre-syntax-ppss (start end) @@ -2138,21 +2176,31 @@ however, smaller in scope than sentences. This is used by (defun treesit-forward-sexp (&optional arg) "Tree-sitter implementation for `forward-sexp-function'. -ARG is described in the docstring of `forward-sexp-function'. If -there are no further sexps to move across, signal `scan-error' -like `forward-sexp' does. If point is already at top-level, -return nil without moving point." +ARG is described in the docstring of `forward-sexp-function'. + +If point is inside a text environment where tree-sitter is not +supported, go forward a sexp using `forward-sexp-default-function'. +If point is inside code, use tree-sitter functions with the +following behavior. If there are no further sexps to move across, +signal `scan-error' like `forward-sexp' does. If point is already +at top-level, return nil without moving point. + +What constitutes as text and source code sexp is determined +by `text' and `sexp' in `treesit-thing-settings'." (interactive "^p") (let ((arg (or arg 1)) (pred (or treesit-sexp-type-regexp 'sexp))) - (or (if (> arg 0) + (or (when (treesit-node-match-p (treesit-node-at (point)) 'text t) + (forward-sexp-default-function arg) + t) + (if (> arg 0) (treesit-end-of-thing pred (abs arg) 'restricted) (treesit-beginning-of-thing pred (abs arg) 'restricted)) ;; If we couldn't move, we should signal an error and report ;; the obstacle, like `forward-sexp' does. If we couldn't ;; find a parent, we simply return nil without moving point, ;; then functions like `up-list' will signal "at top level". - (when-let* ((parent (treesit--thing-at (point) pred t)) + (when-let* ((parent (treesit-thing-at (point) pred t)) (boundary (if (> arg 0) (treesit-node-child parent -1) (treesit-node-child parent 0)))) @@ -2206,18 +2254,14 @@ friends." ;; - treesit-thing/defun-at-point ;; ;; And more generic functions like: -;; - treesit--thing-prev/next -;; - treesit--thing-at -;; - treesit--top-level-thing -;; - treesit--navigate-thing +;; - treesit-thing-prev/next +;; - treesit-thing-at +;; - treesit-top-level-thing +;; - treesit-navigate-thing ;; ;; There are also some defun-specific functions, like ;; treesit-defun-name, treesit-add-log-current-defun. ;; -;; TODO: I'm not entirely sure how would this go, so I only documented -;; the "defun" functions and didn't document any "thing" functions. -;; We should also document `treesit-thing-settings'. - ;; TODO: Integration with thing-at-point: once our thing interface is ;; stable. ;; @@ -2295,7 +2339,7 @@ should there be one. If omitted, TACTIC is considered to be Return non-nil if successfully moved, nil otherwise." (pcase-let* ((arg (or arg 1)) - (dest (treesit--navigate-thing + (dest (treesit-navigate-thing (point) (- arg) 'beg thing tactic))) (when dest (goto-char dest)))) @@ -2318,7 +2362,7 @@ should there be one. If omitted, TACTIC is considered to be Return non-nil if successfully moved, nil otherwise." (pcase-let* ((arg (or arg 1)) - (dest (treesit--navigate-thing + (dest (treesit-navigate-thing (point) arg 'end thing tactic))) (when dest (goto-char dest)))) @@ -2451,68 +2495,6 @@ the current line if the beginning of the defun is indented." (line-beginning-position)) (beginning-of-line)))) -(make-obsolete 'treesit--things-around - "`treesit--things-around' will be removed soon, use `treesit--thing-prev', `treesit--thing-next', `treesit--thing-at' instead." "30.1") -(defun treesit--things-around (pos thing) - "Return the previous, next, and parent thing around POS. - -Return a list of (PREV NEXT PARENT), where PREV and NEXT are -previous and next sibling things around POS, and PARENT is the -parent thing surrounding POS. All of three could be nil if no -sound things exists. - -THING should be a thing defined in `treesit-thing-settings', -which see; it can also be a predicate." - (let* ((node (treesit-node-at pos)) - (result (list nil nil nil))) - ;; 1. Find previous and next sibling defuns. - (cl-loop - for idx from 0 to 1 - for backward in '(t nil) - ;; Make sure we go in the right direction, and the defun we find - ;; doesn't cover POS. - for pos-pred in (list (lambda (n) (<= (treesit-node-end n) pos)) - (lambda (n) (>= (treesit-node-start n) pos))) - ;; We repeatedly find next defun candidate with - ;; `treesit-search-forward', and check if it is a valid defun, - ;; until the node we find covers POS, meaning we've gone through - ;; every possible sibling defuns. But there is a catch: - ;; `treesit-search-forward' searches bottom-up, so for each - ;; candidate we need to go up the tree and find the top-most - ;; valid sibling, this defun will be at the same level as POS. - ;; Don't use `treesit-search-forward-goto', it skips nodes in - ;; order to enforce progress. - when node - do (let ((cursor node) - (iter-pred (lambda (node) - (and (treesit-node-match-p node thing t) - (funcall pos-pred node))))) - ;; Find the node just before/after POS to start searching. - (save-excursion - (while (and cursor (not (funcall pos-pred cursor))) - (setq cursor (treesit-search-forward-goto - cursor "" backward backward t)))) - ;; Keep searching until we run out of candidates. - (while (and cursor - (funcall pos-pred cursor) - (null (nth idx result))) - (setf (nth idx result) - (treesit-node-top-level cursor iter-pred t)) - (setq cursor (treesit-search-forward - cursor thing backward backward))))) - ;; 2. Find the parent defun. - (let ((cursor (or (nth 0 result) (nth 1 result) node)) - (iter-pred (lambda (node) - (and (treesit-node-match-p node thing t) - (not (treesit-node-eq node (nth 0 result))) - (not (treesit-node-eq node (nth 1 result))) - (< (treesit-node-start node) - pos - (treesit-node-end node)))))) - (setf (nth 2 result) - (treesit-parent-until cursor iter-pred))) - result)) - (defun treesit--thing-sibling (pos thing prev) "Return the next or previous THING at POS. @@ -2546,7 +2528,7 @@ in `treesit-thing-settings'." (setq cursor (treesit-search-forward cursor thing prev prev))) sibling))) -(defun treesit--thing-prev (pos thing) +(defun treesit-thing-prev (pos thing) "Return the previous THING at POS. The returned node, if non-nil, must be before POS, i.e., its end @@ -2556,7 +2538,7 @@ THING should be a thing defined in `treesit-thing-settings', or a predicate as described in `treesit-thing-settings'." (treesit--thing-sibling pos thing t)) -(defun treesit--thing-next (pos thing) +(defun treesit-thing-next (pos thing) "Return the next THING at POS. The returned node, if non-nil, must be after POS, i.e., its @@ -2566,7 +2548,7 @@ THING should be a thing defined in `treesit-thing-settings', or a predicate as described in `treesit-thing-settings'." (treesit--thing-sibling pos thing nil)) -(defun treesit--thing-at (pos thing &optional strict) +(defun treesit-thing-at (pos thing &optional strict) "Return the smallest THING enclosing POS. The returned node, if non-nil, must enclose POS, i.e., its start @@ -2611,7 +2593,7 @@ it can be a predicate described in `treesit-thing-settings'." ;; -> Obviously we don't want to go to parent's end, instead, we ;; want to go to parent's prev-sibling's end. Again, we recurse ;; in the function to do that. -(defun treesit--navigate-thing (pos arg side thing &optional tactic recursing) +(defun treesit-navigate-thing (pos arg side thing &optional tactic recursing) "Navigate thing ARG steps from POS. If ARG is positive, move forward that many steps, if negative, @@ -2650,9 +2632,9 @@ function is called recursively." dest))))) (catch 'term (while (> counter 0) - (let ((prev (treesit--thing-prev pos thing)) - (next (treesit--thing-next pos thing)) - (parent (treesit--thing-at pos thing t))) + (let ((prev (treesit-thing-prev pos thing)) + (next (treesit-thing-next pos thing)) + (parent (treesit-thing-at pos thing t))) (when (and parent prev (not (treesit-node-enclosed-p prev parent))) (setq prev nil)) @@ -2702,7 +2684,7 @@ function is called recursively." ;; recurring, that doesn't count as special case, ;; because we have already made progress (by moving ;; the end of next before recurring.) - (setq pos (or (treesit--navigate-thing + (setq pos (or (treesit-navigate-thing (treesit-node-end (or next parent)) 1 'beg thing tactic t) (throw 'term nil))) @@ -2714,7 +2696,7 @@ function is called recursively." (eq pos (funcall advance prev)))) (parent t))) ;; Special case: go to prev end-of-defun. - (setq pos (or (treesit--navigate-thing + (setq pos (or (treesit-navigate-thing (treesit-node-start (or prev parent)) -1 'end thing tactic t) (throw 'term nil))) @@ -2735,7 +2717,7 @@ see `treesit-thing-settings' for details. Return the top-level THING if TACTIC is `top-level'; return the smallest enclosing THING as POS if TACTIC is `nested'." - (let ((node (treesit--thing-at (point) thing))) + (let ((node (treesit-thing-at (point) thing))) (if (eq tactic 'top-level) (treesit-node-top-level node thing t) node))) @@ -2897,20 +2879,26 @@ when a major mode sets it.") "Search for the next outline heading in the syntax tree. See the descriptions of arguments in `outline-search-function'." (if looking-at - (when-let* ((node (or (treesit--thing-at (pos-eol) treesit-outline-predicate) - (treesit--thing-at (pos-bol) treesit-outline-predicate))) + (when-let* ((node (or (treesit-thing-at (pos-eol) treesit-outline-predicate) + (treesit-thing-at (pos-bol) treesit-outline-predicate))) (start (treesit-node-start node))) (eq (pos-bol) (save-excursion (goto-char start) (pos-bol)))) - (let* ((pos + (let* ((bob-pos + ;; `treesit-navigate-thing' can't find a thing at bobp, + ;; so use `looking-at' to match at bobp. + (and (bobp) (treesit-outline-search bound move backward t) (point))) + (pos ;; When function wants to find the current outline, point ;; is at the beginning of the current line. When it wants ;; to find the next outline, point is at the second column. - (if (eq (point) (pos-bol)) - (if (bobp) (point) (1- (point))) - (pos-eol))) - (found (treesit--navigate-thing pos (if backward -1 1) 'beg - treesit-outline-predicate))) + (unless bob-pos + (if (eq (point) (pos-bol)) + (if (bobp) (point) (1- (point))) + (pos-eol)))) + (found (or bob-pos + (treesit-navigate-thing pos (if backward -1 1) 'beg + treesit-outline-predicate)))) (if found (if (or (not bound) (if backward (>= found bound) (<= found bound))) (progn @@ -3012,14 +3000,8 @@ before calling this function." (font-lock-fontify-syntactically-function . treesit-font-lock-fontify-region))) (treesit-font-lock-recompute-features) - (dolist (parser (treesit-parser-list)) - (treesit-parser-add-notifier - parser #'treesit--font-lock-notifier)) (add-hook 'pre-redisplay-functions #'treesit--pre-redisplay 0 t)) ;; Syntax - (dolist (parser (treesit-parser-list)) - (treesit-parser-add-notifier - parser #'treesit--syntax-propertize-notifier)) (add-hook 'syntax-propertize-extend-region-functions #'treesit--pre-syntax-ppss 0 t) ;; Indent. diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 5f45b98c7a5..4d2609cbb95 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -242,45 +242,6 @@ Will not do anything if `url-show-status' is nil." (setq retval (cons (list key val) retval))))) retval)) -;;;###autoload -(defun url-build-query-string (query &optional semicolons keep-empty) - "Build a query-string. - -Given a QUERY in the form: - ((key1 val1) - (key2 val2) - (key3 val1 val2) - (key4) - (key5 \"\")) - -\(This is the same format as produced by `url-parse-query-string') - -This will return a string -\"key1=val1&key2=val2&key3=val1&key3=val2&key4&key5\". Keys may -be strings or symbols; if they are symbols, the symbol name will -be used. - -When SEMICOLONS is given, the separator will be \";\". - -When KEEP-EMPTY is given, empty values will show as \"key=\" -instead of just \"key\" as in the example above." - (mapconcat - (lambda (key-vals) - (let ((escaped - (mapcar (lambda (sym) - (url-hexify-string (format "%s" sym))) key-vals))) - (mapconcat (lambda (val) - (let ((vprint (format "%s" val)) - (eprint (format "%s" (car escaped)))) - (concat eprint - (if (or keep-empty - (and val (not (zerop (length vprint))))) - "=" - "") - vprint))) - (or (cdr escaped) '("")) (if semicolons ";" "&")))) - query (if semicolons ";" "&"))) - (defun url-unhex (x) (if (> x ?9) (if (>= x ?a) @@ -410,6 +371,15 @@ These characters are specified in RFC 3986, Appendix A.") "Allowed-character byte mask for the query segment of a URI. These characters are specified in RFC 3986, Appendix A.") +(defconst url-query-key-value-allowed-chars + (let ((vec (copy-sequence url-query-allowed-chars))) + (aset vec ?= nil) + (aset vec ?& nil) + (aset vec ?\; nil) + vec) + "Allowed-charcter byte mask for keys and values in the query segment of a URI. +url-query-allowed-chars minus '=', '&', and ';'.") + ;;;###autoload (defun url-encode-url (url) "Return a properly URI-encoded version of URL. @@ -440,6 +410,47 @@ should return it unchanged." (url-recreate-url obj))) ;;;###autoload +(defun url-build-query-string (query &optional semicolons keep-empty) + "Build a query-string. + +Given a QUERY in the form: + ((key1 val1) + (key2 val2) + (key3 val1 val2) + (key4) + (key5 \"\")) + +\(This is the same format as produced by `url-parse-query-string') + +This will return a string +\"key1=val1&key2=val2&key3=val1&key3=val2&key4&key5\". Keys may +be strings or symbols; if they are symbols, the symbol name will +be used. + +When SEMICOLONS is given, the separator will be \";\". + +When KEEP-EMPTY is given, empty values will show as \"key=\" +instead of just \"key\" as in the example above." + (mapconcat + (lambda (key-vals) + (let ((escaped + (mapcar (lambda (sym) + (url-hexify-string (format "%s" sym) + url-query-key-value-allowed-chars)) + key-vals))) + (mapconcat (lambda (val) + (let ((vprint (format "%s" val)) + (eprint (format "%s" (car escaped)))) + (concat eprint + (if (or keep-empty + (and val (not (zerop (length vprint))))) + "=" + "") + vprint))) + (or (cdr escaped) '("")) (if semicolons ";" "&")))) + query (if semicolons ";" "&"))) + +;;;###autoload (defun url-file-extension (fname &optional x) "Return the filename extension of FNAME. If optional argument X is t, then return the basename diff --git a/lisp/use-package/use-package-core.el b/lisp/use-package/use-package-core.el index d9343e14839..ba2e93c97e9 100644 --- a/lisp/use-package/use-package-core.el +++ b/lisp/use-package/use-package-core.el @@ -346,6 +346,20 @@ undefined variables." :type 'boolean :group 'use-package) +(defcustom use-package-vc-prefer-newest nil + "Prefer the newest commit over the latest release. +By default, much like GNU ELPA and NonGNU ELPA, the `:vc' keyword +tracks the latest stable release of a package. If this option is +non-nil, the latest commit is preferred instead. This has the +same effect as specifying `:rev :newest' in every invocation of +`:vc'. + +Note that always tracking a package's latest commit might lead to +stability issues." + :type 'boolean + :version "30.1" + :group 'use-package) + (defvar use-package-statistics (make-hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1649,9 +1663,11 @@ indicating the latest commit) revision." (if (and s (stringp s)) (intern s) s)) (normalize (k v) (pcase k - (:rev (cond ((or (eq v :last-release) (not v)) :last-release) - ((eq v :newest) nil) - (t (ensure-string v)))) + (:rev (pcase v + ('nil (if use-package-vc-prefer-newest nil :last-release)) + (:last-release :last-release) + (:newest nil) + (_ (ensure-string v)))) (:vc-backend (ensure-symbol v)) (_ (ensure-string v))))) (pcase-let ((valid-kws '(:url :branch :lisp-dir :main-file :vc-backend :rev)) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 66043059d14..e1837eab12a 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -53,9 +53,10 @@ ;; - Handle `diff -b' output in context->unified. ;;; Code: +(require 'easy-mmode) +(require 'track-changes) (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'subr-x)) -(require 'easy-mmode) (autoload 'vc-find-revision "vc") (autoload 'vc-find-revision-no-save "vc") @@ -1431,38 +1432,23 @@ else cover the whole buffer." (if (buffer-modified-p) (diff-fixup-modifs (point-min) (point-max))) nil) -;; It turns out that making changes in the buffer from within an -;; *-change-function is asking for trouble, whereas making them -;; from a post-command-hook doesn't pose much problems -(defvar diff-unhandled-changes nil) -(defun diff-after-change-function (beg end _len) - "Remember to fixup the hunk header. -See `after-change-functions' for the meaning of BEG, END and LEN." - ;; Ignoring changes when inhibit-read-only is set is strictly speaking - ;; incorrect, but it turns out that inhibit-read-only is normally not set - ;; inside editing commands, while it tends to be set when the buffer gets - ;; updated by an async process or by a conversion function, both of which - ;; would rather not be uselessly slowed down by this hook. - (when (and (not undo-in-progress) (not inhibit-read-only)) - (if diff-unhandled-changes - (setq diff-unhandled-changes - (cons (min beg (car diff-unhandled-changes)) - (max end (cdr diff-unhandled-changes)))) - (setq diff-unhandled-changes (cons beg end))))) - -(defun diff-post-command-hook () - "Fixup hunk headers if necessary." - (when (consp diff-unhandled-changes) - (ignore-errors - (save-excursion - (goto-char (car diff-unhandled-changes)) - ;; Maybe we've cut the end of the hunk before point. - (if (and (bolp) (not (bobp))) (backward-char 1)) - ;; We used to fixup modifs on all the changes, but it turns out that - ;; it's safer not to do it on big changes, e.g. when yanking a big - ;; diff, or when the user edits the header, since we might then - ;; screw up perfectly correct values. --Stef - (diff-beginning-of-hunk t) +(defvar-local diff--track-changes nil) + +(defun diff--track-changes-signal (tracker) + (cl-assert (eq tracker diff--track-changes)) + (track-changes-fetch tracker #'diff--track-changes-function)) + +(defun diff--track-changes-function (beg end _before) + (with-demoted-errors "%S" + (save-excursion + (goto-char beg) + ;; Maybe we've cut the end of the hunk before point. + (if (and (bolp) (not (bobp))) (backward-char 1)) + ;; We used to fixup modifs on all the changes, but it turns out that + ;; it's safer not to do it on big changes, e.g. when yanking a big + ;; diff, or when the user edits the header, since we might then + ;; screw up perfectly correct values. --Stef + (when (ignore-errors (diff-beginning-of-hunk t)) (let* ((style (if (looking-at "\\*\\*\\*") 'context)) (start (line-beginning-position (if (eq style 'context) 3 2))) (mid (if (eq style 'context) @@ -1470,17 +1456,20 @@ See `after-change-functions' for the meaning of BEG, END and LEN." (re-search-forward diff-context-mid-hunk-header-re nil t))))) (when (and ;; Don't try to fixup changes in the hunk header. - (>= (car diff-unhandled-changes) start) + (>= beg start) ;; Don't try to fixup changes in the mid-hunk header either. (or (not mid) - (< (cdr diff-unhandled-changes) (match-beginning 0)) - (> (car diff-unhandled-changes) (match-end 0))) + (< end (match-beginning 0)) + (> beg (match-end 0))) (save-excursion - (diff-end-of-hunk nil 'donttrustheader) + (diff-end-of-hunk nil 'donttrustheader) ;; Don't try to fixup changes past the end of the hunk. - (>= (point) (cdr diff-unhandled-changes)))) - (diff-fixup-modifs (point) (cdr diff-unhandled-changes))))) - (setq diff-unhandled-changes nil)))) + (>= (point) end))) + (diff-fixup-modifs (point) end) + ;; Ignore the changes we just made ourselves. + ;; This is not indispensable since the above `when' skips + ;; changes like the ones we make anyway, but it's good practice. + (track-changes-fetch diff--track-changes #'ignore))))))) (defun diff-next-error (arg reset) ;; Select a window that displays the current buffer so that point @@ -1560,9 +1549,8 @@ a diff with \\[diff-reverse-direction]. ;; setup change hooks (if (not diff-update-on-the-fly) (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) - (make-local-variable 'diff-unhandled-changes) - (add-hook 'after-change-functions #'diff-after-change-function nil t) - (add-hook 'post-command-hook #'diff-post-command-hook nil t)) + (setq diff--track-changes + (track-changes-register #'diff--track-changes-signal :nobefore t))) ;; add-log support (setq-local add-log-current-defun-function #'diff-current-defun) @@ -1581,12 +1569,15 @@ a diff with \\[diff-reverse-direction]. \\{diff-minor-mode-map}" :group 'diff-mode :lighter " Diff" ;; FIXME: setup font-lock - ;; setup change hooks - (if (not diff-update-on-the-fly) - (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) - (make-local-variable 'diff-unhandled-changes) - (add-hook 'after-change-functions #'diff-after-change-function nil t) - (add-hook 'post-command-hook #'diff-post-command-hook nil t))) + (when diff--track-changes (track-changes-unregister diff--track-changes)) + (remove-hook 'write-contents-functions #'diff-write-contents-hooks t) + (when diff-minor-mode + (if (not diff-update-on-the-fly) + (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) + (unless diff--track-changes + (setq diff--track-changes + (track-changes-register #'diff--track-changes-signal + :nobefore t)))))) ;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index f8d4c1c1c4b..2d5d4609890 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -721,10 +721,11 @@ optional argument, then use it." nil ; don't redisplay shell-command-switch ; usually -c (format "%s %s %s %s" - ediff-patch-program + (shell-quote-argument ediff-patch-program) ediff-patch-options ediff-backup-specs - (ediff--buffer-file-name buf-to-patch)) + (shell-quote-argument + (ediff--buffer-file-name buf-to-patch))) )) ;; restore environment for gnu patch diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 1f766eea455..d61a108b195 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -698,7 +698,15 @@ according to `fill-column'." (save-excursion (goto-char beg) (when (re-search-forward - "^[[:blank:]]*(.*\\([[:space:]]\\).*):" + ;; Also replace spaces within defun lists + ;; prefixed by a file name so that + ;; fill-region never attempts to break + ;; them, even if multiple items combine + ;; with symbols to exceed the fill column + ;; by the expressly permitted margin of 1 + ;; character. + (concat "^\\([[:blank:]]*\\|\\* .*[[:blank:]]" + "\\)(.*\\([[:space:]]\\).*):") end t) (replace-regexp-in-region "[[:space:]]" " " (setq space-beg diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 15c1b83fcc1..bc23a8794eb 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2474,7 +2474,7 @@ purposes)." (let ((i (length vec))) (when (> i 0) (while (and (>= (setq i (1- i)) 0) - (whitespace-char-valid-p (aref vec i)))) + (whitespace-char-valid-p (glyph-char (aref vec i))))) (< i 0)))) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 172da3db1e0..3b467434d29 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -141,12 +141,21 @@ This exists as a variable so it can be set locally in certain buffers.") :background "dim gray" :box (:line-width (1 . -1) :color "gray46") :extend t) + ;; Monochrome displays. + (((background light)) + :background "white" + :box (:line-width (1 . -1) :color "black") + :extend t) + (((background dark)) + :background "black" + :box (:line-width (1 . -1) :color "white") + :extend t) (t :slant italic :extend t)) "Face used for editable fields." :group 'widget-faces - :version "28.1") + :version "30.1") (defface widget-single-line-field '((((type tty)) :background "green3" @@ -157,6 +166,10 @@ This exists as a variable so it can be set locally in certain buffers.") (((class grayscale color) (background dark)) :background "dim gray") + ;; Monochrome displays. + (((background light)) + :stipple "gray3" + :extend t) (t :slant italic)) "Face used for editable fields spanning only a single line." @@ -1093,77 +1106,92 @@ If nothing was called, return non-nil." (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1))) (pos (widget-event-point event)) newpoint) - (catch 'button-press-cancelled - ;; Mouse click on a widget button. Do the following - ;; in a save-excursion so that the click on the button - ;; doesn't change point. - (save-selected-window - (select-window (posn-window (event-start event))) - (save-excursion - (goto-char (posn-point (event-start event))) - (let* ((overlay (widget-get button :button-overlay)) - (pressed-face (or (widget-get button :pressed-face) - widget-button-pressed-face)) - (face (overlay-get overlay 'face)) - (mouse-face (overlay-get overlay 'mouse-face))) - (unwind-protect - ;; Read events, including mouse-movement events, - ;; waiting for a release event. If we began with a - ;; mouse-1 event and receive a movement event, that - ;; means the user wants to perform drag-selection, so - ;; cancel the button press and do the default mouse-1 - ;; action. For mouse-2, just highlight/ unhighlight - ;; the button the mouse was initially on when we move - ;; over it. - ;; - ;; If this function was called in response to a - ;; touchscreen event, then wait for a corresponding - ;; touchscreen-end event instead. - (save-excursion - (when face ; avoid changing around image - (overlay-put overlay 'face pressed-face) - (overlay-put overlay 'mouse-face pressed-face)) - (if (eq (car event) 'touchscreen-begin) - ;; This a touchscreen event and must be handled - ;; specially through `touch-screen-track-tap'. - (progn - (unless (touch-screen-track-tap event nil nil t) - (throw 'button-press-cancelled t))) - (unless (widget-apply button :mouse-down-action event) - (let ((track-mouse t)) - (while (not (widget-button-release-event-p event)) - (setq event (read--potential-mouse-event)) - (when (and mouse-1 (mouse-movement-p event)) - (push event unread-command-events) - (setq event oevent) - (throw 'button-press-cancelled t)) - (unless (or (integerp event) - (memq (car event) - '(switch-frame select-window)) - (eq (car event) 'scroll-bar-movement)) - (setq pos (widget-event-point event)) - (if (and pos - (eq (get-char-property pos 'button) - button)) - (when face - (overlay-put overlay 'face pressed-face) - (overlay-put overlay 'mouse-face pressed-face)) - (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face))))))) - - ;; When mouse is released over the button, run - ;; its action function. - (when (and pos (eq (get-char-property pos 'button) button)) - (goto-char pos) - (widget-apply-action button event) - (if widget-button-click-moves-point - (setq newpoint (point))))) - (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face)))) - - (when newpoint - (goto-char newpoint))) - nil))) + (setq newpoint + (catch 'button-press-cancelled + ;; Mouse click on a widget button. Do the following + ;; in a save-excursion so that the click on the button + ;; doesn't change point. + (save-selected-window + (select-window (posn-window (event-start event))) + (save-excursion + (goto-char (posn-point (event-start event))) + (let* ((overlay (widget-get button :button-overlay)) + (pressed-face (or (widget-get button :pressed-face) + widget-button-pressed-face)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) + (unwind-protect + ;; Read events, including mouse-movement events, + ;; waiting for a release event. If we began with + ;; a mouse-1 event and receive a movement event, + ;; that means the user wants to perform + ;; drag-selection, so cancel the button press and + ;; do the default mouse-1 action. For mouse-2, + ;; just highlight/ unhighlight the button the + ;; mouse was initially on when we move over it. + ;; + ;; If this function was called in response to a + ;; touchscreen event, then wait for a + ;; corresponding touchscreen-end event instead. + (save-excursion + (when face ; avoid changing around image + (overlay-put overlay 'face pressed-face) + (overlay-put overlay 'mouse-face pressed-face)) + (if (eq (car event) 'touchscreen-begin) + ;; This a touchscreen event and must be + ;; handled specially through + ;; `touch-screen-track-tap'. + (progn + (unless (touch-screen-track-tap event nil nil t) + ;; Report the current position of point + ;; to the catch block. + (throw 'button-press-cancelled (point)))) + (unless (widget-apply button :mouse-down-action event) + (let ((track-mouse t)) + (while (not (widget-button-release-event-p event)) + (setq event (read--potential-mouse-event)) + (when (and mouse-1 (mouse-movement-p event)) + (push event unread-command-events) + (setq event oevent) + (throw 'button-press-cancelled nil)) + (unless (or (integerp event) + (memq (car event) + '(switch-frame select-window)) + (eq (car event) + 'scroll-bar-movement)) + (setq pos (widget-event-point event)) + (if (and pos + (eq (get-char-property pos 'button) + button)) + (when face + (overlay-put overlay + 'face pressed-face) + (overlay-put overlay + 'mouse-face pressed-face)) + (overlay-put overlay + 'face face) + (overlay-put overlay + 'mouse-face mouse-face))))))) + + ;; When mouse is released over the button, run + ;; its action function. + (when (and pos (eq (get-char-property pos 'button) + button)) + (goto-char pos) + (widget-apply-action button event) + (if widget-button-click-moves-point + (setq newpoint (point))))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) + (when newpoint + (goto-char newpoint))) + nil)) + ;; Return to the position of point as it existed during the + ;; button-tracking loop if the event being tracked is a touch screen + ;; event, to prevent hscroll from being disturbed by movement of + ;; point to any previous location outside the visible confines of + ;; the window. + (when newpoint (goto-char newpoint)))) (defun widget-button-click (event) "Invoke the button that the mouse is pointing at." @@ -1219,11 +1247,20 @@ If nothing was called, return non-nil." (when (commandp command) (call-interactively command)))))) +(defcustom widget-skip-inactive nil + "If non-nil, skip inactive widgets when tabbing through buffer." + :version "30.1" + :group 'widgets + :type 'boolean) + (defun widget-tabable-at (&optional pos) "Return the tabable widget at POS, or nil. -POS defaults to the value of (point)." +POS defaults to the value of (point). If user option +`widget-skip-inactive' is non-nil, inactive widgets are not tabable." (let ((widget (widget-at pos))) - (if widget + (if (and widget (if widget-skip-inactive + (widget-apply widget :active) + t)) (let ((order (widget-get widget :tab-order))) (if order (if (>= order 0) @@ -1276,9 +1313,9 @@ nothing is shown in the echo area." (unless (eq new old) (setq arg (1+ arg)))))) (let ((new (widget-tabable-at))) - (while (eq (widget-tabable-at) new) + (while (and (eq (widget-tabable-at) new) (not (bobp))) (backward-char))) - (forward-char)) + (unless (bobp) (forward-char))) (unless suppress-echo (widget-echo-help (point))) (run-hooks 'widget-move-hook)) diff --git a/lisp/window.el b/lisp/window.el index df55a7ca673..639090752be 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2515,7 +2515,8 @@ have special meanings: Any other value of ALL-FRAMES means consider all windows on the selected frame and no others." - (declare (side-effect-free error-free)) + (declare (type (function (&optional t t t) (or window null))) + (side-effect-free error-free)) (let ((windows (window-list-1 nil 'nomini all-frames)) best-window best-time second-best-window second-best-time time) (dolist (window windows) @@ -2594,7 +2595,8 @@ have special meanings: Any other value of ALL-FRAMES means consider all windows on the selected frame and no others." - (declare (side-effect-free error-free)) + (declare (type (function (&optional t t t) (or window null))) + (side-effect-free error-free)) (let ((best-size 0) best-window size) (dolist (window (window-list-1 nil 'nomini all-frames)) @@ -4089,7 +4091,8 @@ with a special meaning are: Anything else means consider all windows on the selected frame and no others." - (declare (side-effect-free error-free)) + (declare (type (function (&optional t t) boolean)) + (side-effect-free error-free)) (let ((base-window (selected-window))) (if (and nomini (eq base-window (minibuffer-window))) (setq base-window (next-window base-window))) @@ -7856,6 +7859,10 @@ Action alist entries are: window that was selected before calling this function will remain selected regardless of which windows were selected afterwards within this command. + `category' -- If the caller of `display-buffer' passes an alist entry + `(category . symbol)' in its action argument, then you can match + the displayed buffer by using the same category in the condition + part of `display-buffer-alist' entries. The entries `window-height', `window-width', `window-size' and `preserve-size' are applied only when the window used for @@ -8919,7 +8926,8 @@ currently selected window; otherwise it will be displayed in another window." (pop-to-buffer buffer display-buffer--same-window-action norecord)) -(defcustom display-comint-buffer-action display-buffer--same-window-action +(defcustom display-comint-buffer-action + (append display-buffer--same-window-action '((category . comint))) "`display-buffer' action for displaying comint buffers." :type display-buffer--action-custom-type :risky t @@ -8927,8 +8935,14 @@ another window." :group 'windows :group 'comint) +(make-obsolete-variable + 'display-comint-buffer-action + "use a `(category . comint)' condition in `display-buffer-alist'." + "30.1") + (defcustom display-tex-shell-buffer-action '(display-buffer-in-previous-window - (inhibit-same-window . t)) + (inhibit-same-window . t) + (category . tex-shell)) "`display-buffer' action for displaying TeX shell buffers." :type display-buffer--action-custom-type :risky t @@ -8936,6 +8950,11 @@ another window." :group 'windows :group 'tex-run) +(make-obsolete-variable + 'display-tex-shell-buffer-action + "use a `(category . tex-shell)' condition in `display-buffer-alist'." + "30.1") + (defun read-buffer-to-switch (prompt) "Read the name of a buffer to switch to, prompting with PROMPT. Return the name of the buffer as a string. @@ -10834,6 +10853,79 @@ displaying that processes's buffer." (set-process-window-size process (cdr size) (car size)))))))))) (add-hook 'window-configuration-change-hook 'window--adjust-process-windows) + + +;;; Window point context + +(defun window-point-context-set () + "Set context near the window point. +Call function specified by `window-point-context-set-function' for every +live window on the selected frame with that window as sole argument. +The function called is supposed to return a context of the window's point +that can be later used as argument for `window-point-context-use-function'. +Remember the returned context in the window parameter `context'." + (walk-windows + (lambda (w) + (when-let ((fn (buffer-local-value 'window-point-context-set-function + (window-buffer w))) + ((functionp fn)) + (context (funcall fn w))) + (set-window-parameter + w 'context (cons (buffer-name (window-buffer w)) context)))) + 'nomini)) + +(defun window-point-context-use () + "Use context to relocate the window point. +Call function specified by `window-point-context-use-function' to move the +window point according to the previously saved context. For every live +window on the selected frame this function is called with two arguments: +the window and the context data structure saved by +`window-point-context-set-function' in the window parameter `context'. +The function called is supposed to set the window point to the location +found by the provided context." + (walk-windows + (lambda (w) + (when-let ((fn (buffer-local-value 'window-point-context-use-function + (window-buffer w))) + ((functionp fn)) + (context (window-parameter w 'context)) + ((equal (buffer-name (window-buffer w)) (car context)))) + (funcall fn w (cdr context)) + (set-window-parameter w 'context nil))) + 'nomini)) + +(add-to-list 'window-persistent-parameters '(context . writable)) + +(defun window-point-context-set-default-function (w) + "Set context of file buffers to the front and rear strings." + (with-current-buffer (window-buffer w) + (when buffer-file-name + (let ((point (window-point w))) + `((front-context-string + . ,(buffer-substring-no-properties + point (min (+ point 16) (point-max)))) + (rear-context-string + . ,(buffer-substring-no-properties + point (max (- point 16) (point-min))))))))) + +(defun window-point-context-use-default-function (w context) + "Restore context of file buffers by the front and rear strings." + (with-current-buffer (window-buffer w) + (let ((point (window-point w))) + (save-excursion + (goto-char point) + (when-let ((f (alist-get 'front-context-string context)) + ((search-forward f (point-max) t))) + (goto-char (match-beginning 0)) + (when-let ((r (alist-get 'rear-context-string context)) + ((search-backward r (point-min) t))) + (goto-char (match-end 0)) + (setq point (point))))) + (set-window-point w point)))) + +(defvar window-point-context-set-function 'window-point-context-set-default-function) +(defvar window-point-context-use-function 'window-point-context-use-default-function) + ;; Some of these are in tutorial--default-keys, so update that if you ;; change these. diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el index 081b8f32456..8cbb44ece14 100644 --- a/lisp/xt-mouse.el +++ b/lisp/xt-mouse.el @@ -40,8 +40,6 @@ ;;; Code: -(require 'mwheel) - (defvar xterm-mouse-debug-buffer nil) (defun xterm-mouse-translate (_event) @@ -60,7 +58,9 @@ https://invisible-island.net/xterm/ctlseqs/ctlseqs.html)." (let* ((event (xterm-mouse-event extension)) (ev-command (nth 0 event)) (ev-data (nth 1 event)) + (ev-window (nth 0 ev-data)) (ev-where (nth 1 ev-data)) + (last-window (terminal-parameter nil 'xterm-mouse-last-window)) (vec (vector event)) (is-move (eq 'mouse-movement ev-command)) (is-down (string-match "down-" (symbol-name ev-command)))) @@ -73,6 +73,9 @@ https://invisible-island.net/xterm/ctlseqs/ctlseqs.html)." 'mouse-movement 'mouse-click))) + ;; remember window of current mouse position + (set-terminal-parameter nil 'xterm-mouse-last-window ev-window) + (cond ((null event) nil) ;Unknown/bogus byte sequence! (is-down @@ -84,10 +87,22 @@ https://invisible-island.net/xterm/ctlseqs/ctlseqs.html)." vec) (is-move (xterm-mouse--handle-mouse-movement) - (if track-mouse vec - ;; Mouse movement events are currently supposed to be - ;; suppressed. Return no event. - [])) + ;; after mouse movement autoselect the mouse window, but ... + (cond ((and mouse-autoselect-window + ;; ignore modeline, tab-bar, menu-bar and so forth ... + (windowp ev-window) + ;; and don't deselect the minibuffer ... + (not (window-minibuffer-p (selected-window))) + ;; and select only, if mouse is over a new window ... + (not (eq ev-window last-window)) + ;; which is different from the selected window + (not (eq ev-window (selected-window)))) + (put 'select-window 'event-kind 'switch-frame) + (push `(select-window (,ev-window)) unread-command-events) + []) + ;;(vector `(select-window (,ev-window)))) + (track-mouse vec) + (t []))) (t (let* ((down (terminal-parameter nil 'xterm-mouse-last-down)) (down-data (nth 1 down)) @@ -195,12 +210,6 @@ single byte." (cons n c)) (cons (- (setq c (xterm-mouse--read-coordinate)) 32) c)))) -(defun xterm-mouse--button-p (event btn) - (and (symbolp event) - (string-prefix-p "mouse-" (symbol-name event)) - (eq btn (car (read-from-string (symbol-name event) - (length "mouse-")))))) - ;; XTerm reports mouse events as ;; <EVENT-CODE> <X> <Y> in default mode, and ;; <EVENT-CODE> ";" <X> ";" <Y> <"M" or "m"> in extended mode. @@ -246,14 +255,10 @@ single byte." (if meta "M-" "") (if shift "S-" "") (if down "down-" "") - (cond - ;; BEWARE: `mouse-wheel-UP-event' corresponds to - ;; `wheel-DOWN' events and vice versa!! - ((xterm-mouse--button-p mouse-wheel-down-event btn) "wheel-up") - ((xterm-mouse--button-p mouse-wheel-up-event btn) "wheel-down") - ((xterm-mouse--button-p mouse-wheel-left-event btn) "wheel-left") - ((xterm-mouse--button-p mouse-wheel-right-event btn) "wheel-right") - (t (format "mouse-%d" btn)))))))) + (let ((remap (alist-get btn mouse-wheel-buttons))) + (if remap + (symbol-name remap) + (format "mouse-%d" btn)))))))) (list sym (1- x) (1- y)))) (defun xterm-mouse--set-click-count (event click-count) diff --git a/m4/ndk-build.m4 b/m4/ndk-build.m4 index 7012471e046..2689ee34287 100644 --- a/m4/ndk-build.m4 +++ b/m4/ndk-build.m4 @@ -69,7 +69,7 @@ AS_CASE(["$ndk_ABI"], # This is a map between pkg-config style package names and Android # ones. -ndk_package_map="libwebpdemux:webpdemux libxml-2.0:libxml2 jansson:libjansson" +ndk_package_map="libwebpdemux:webpdemux libxml-2.0:libxml2" ndk_package_map="$ndk_package_map sqlite3:libsqlite_static_minimal" ndk_package_map="$ndk_package_map MagickWand:libmagickwand-7 lcms2:liblcms2" @@ -339,6 +339,16 @@ NDK_BUILD_NASM= AS_IF([test "$ndk_ARCH" = "x86" || test "$ndk_ARCH" = "x86_64"], [AC_CHECK_PROGS([NDK_BUILD_NASM], [nasm])]) +# Search for a suitable readelf binary, which is required to generate +# the shared library list loaded on old Android systems. +AC_PATH_PROGS([READELF], [readelf llvm-readelf $host_alias-readelf], + [], [$ndk_ranlib_search_path:$PATH]) +AS_IF([test -z "$READELF"], + [AC_MSG_ERROR([A suitable `readelf' utility cannot be located. +Please verify that the Android NDK has been installed correctly, +or install a functioning `readelf' yourself.])]) +NDK_BUILD_READELF="$READELF" + # Search for a C++ compiler. Upon failure, pretend the C compiler is a # C++ compiler and use that instead. @@ -644,6 +654,7 @@ AC_DEFUN_ONCE([ndk_CONFIG_FILES], AC_SUBST([NDK_BUILD_CXX_LDFLAGS]) AC_SUBST([NDK_BUILD_ANY_CXX_MODULE]) AC_SUBST([NDK_BUILD_CFLAGS]) + AC_SUBST([NDK_BUILD_READELF]) AC_CONFIG_FILES([$ndk_DIR/Makefile]) AC_CONFIG_FILES([$ndk_DIR/ndk-build.mk]) diff --git a/msdos/sed1v2.inp b/msdos/sed1v2.inp index 632c45a16b6..da056067548 100644 --- a/msdos/sed1v2.inp +++ b/msdos/sed1v2.inp @@ -175,9 +175,6 @@ s/ *@WEBP_LIBS@// /^CANNOT_DUMP *=/s/@CANNOT_DUMP@/no/ /^W32_OBJ *=/s/@W32_OBJ@// /^W32_LIBS *=/s/@W32_LIBS@// -/^JSON_OBJ *=/s/@JSON_OBJ@// -/^JSON_CFLAGS *=/s/@JSON_CFLAGS@// -/^JSON_LIBS *=/s/@JSON_LIBS@// /^LIBGCCJIT_OBJ *=/s/@LIBGCCJIT_OBJ@// /^LIBGCCJIT_CFLAGS *=/s/@LIBGCCJIT_CFLAGS@// /^LIBGCCJIT_LIBS *=/s/@LIBGCCJIT_LIBS@// diff --git a/nt/INSTALL b/nt/INSTALL index 77626f8a343..6167365169b 100644 --- a/nt/INSTALL +++ b/nt/INSTALL @@ -508,7 +508,6 @@ build should run on Windows 9X and newer systems). Does Emacs use -lotf? no Does Emacs use -lxft? no Does Emacs use -lsystemd? no - Does Emacs use -ljansson? yes Does Emacs use the GMP library? yes Does Emacs directly use zlib? yes Does Emacs have dynamic modules support? yes @@ -830,13 +829,6 @@ build should run on Windows 9X and newer systems). Prebuilt binaries of lcms2 DLL (for 32-bit builds of Emacs) are available from the ezwinports site and from the MSYS2 project. -* Optional support for JSON - - Emacs can provide built-in support for JSON parsing and - serialization using the libjansson library. Prebuilt binaries of - the libjansson DLL (for 32-bit builds of Emacs) are available from - the ezwinports site and from the MSYS2 project. - * Optional support for HarfBuzzz shaping library Emacs supports display of complex scripts and Arabic shaping. The diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64 index 2aa05ea0062..d25fc2e18af 100644 --- a/nt/INSTALL.W64 +++ b/nt/INSTALL.W64 @@ -55,7 +55,6 @@ packages (you can copy and paste it into the shell with Shift + Insert): mingw-w64-x86_64-librsvg \ mingw-w64-x86_64-libwebp \ mingw-w64-x86_64-lcms2 \ - mingw-w64-x86_64-jansson \ mingw-w64-x86_64-libxml2 \ mingw-w64-x86_64-zlib \ mingw-w64-x86_64-harfbuzz \ diff --git a/src/.gdbinit b/src/.gdbinit index 6c4dda67f06..7645d466a5e 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -822,15 +822,22 @@ Print $ as a frame pointer. This command assumes $ is an Emacs Lisp frame value. end -define xcompiled +define xclosure xgetptr $ print (struct Lisp_Vector *) $ptr output ($->contents[0])@($->header.size & 0xff) echo \n end +document xclosure +Print $ as a function pointer. +This command assumes that $ is an Emacs Lisp byte-code or interpreted function value. +end + +define xcompiled + xclosure +end document xcompiled -Print $ as a compiled function pointer. -This command assumes that $ is an Emacs Lisp compiled value. +Obsolete alias for "xclosure". end define xwindow @@ -1038,8 +1045,8 @@ define xpr if $vec == PVEC_FRAME xframe end - if $vec == PVEC_COMPILED - xcompiled + if $vec == PVEC_CLOSURE + xclosure end if $vec == PVEC_WINDOW xwindow diff --git a/src/Makefile.in b/src/Makefile.in index de45b2290f1..e839a74dabf 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -361,10 +361,6 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@ LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ -JSON_LIBS = @JSON_LIBS@ -JSON_CFLAGS = @JSON_CFLAGS@ -JSON_OBJ = @JSON_OBJ@ - TREE_SITTER_LIBS = @TREE_SITTER_LIBS@ TREE_SITTER_CFLAGS = @TREE_SITTER_CFLAGS@ @@ -421,7 +417,8 @@ pdmp := endif # Flags that might be in WARN_CFLAGS but are not valid for Objective C. -NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd -Wnested-externs +NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd \ + -Wnested-externs -Wstrict-flex-arrays # Ditto, but for C++. NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \ -Wstrict-prototypes -Wno-override-init @@ -438,7 +435,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(XINPUT_CFLAGS) $(WEBP_CFLAGS) $(WEBKIT_CFLAGS) $(LCMS2_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ - $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) $(XSYNC_CFLAGS) $(TREE_SITTER_CFLAGS) \ + $(LIBSYSTEMD_CFLAGS) $(XSYNC_CFLAGS) $(TREE_SITTER_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ $(WERROR_CFLAGS) $(HAIKU_CFLAGS) $(XCOMPOSITE_CFLAGS) $(XSHAPE_CFLAGS) \ $(ANDROID_BUILD_CFLAGS) $(GIF_CFLAGS) $(JPEG_CFLAGS) $(SQLITE3_CFLAGS) \ @@ -476,10 +473,10 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ $(XWIDGETS_OBJ) \ profiler.o decompress.o \ thread.o systhread.o sqlite.o treesit.o \ - itree.o \ + itree.o json.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) \ + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) \ $(HAIKU_OBJ) $(PGTK_OBJ) $(ANDROID_OBJ) doc_obj = $(base_obj) $(NS_OBJC_OBJ) obj = $(doc_obj) $(HAIKU_CXX_OBJ) @@ -498,7 +495,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o hbfont.o \ haikuterm.o haikufns.o haikumenu.o haikufont.o androidterm.o androidfns.o \ - androidfont.o androidselect.c sfntfont-android.c sfntfont.c + androidfont.o androidselect.c androidvfs.c sfntfont-android.c sfntfont.c ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. GMALLOC_OBJ=@GMALLOC_OBJ@ @@ -604,7 +601,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(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) \ + $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) \ $(TREE_SITTER_LIBS) $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS) \ $(ANDROID_LIBS) diff --git a/src/alloc.c b/src/alloc.c index 2ffd2415447..4226cb1d1a0 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -668,10 +668,10 @@ malloc_warning (const char *str) void display_malloc_warning (void) { - call3 (intern ("display-warning"), - intern ("alloc"), + call3 (Qdisplay_warning, + Qalloc, build_string (pending_malloc_warning), - intern (":emergency")); + QCemergency); pending_malloc_warning = 0; } @@ -3481,7 +3481,7 @@ cleanup_vector (struct Lisp_Vector *vector) case PVEC_XWIDGET_VIEW: case PVEC_TS_NODE: case PVEC_SQLITE: - case PVEC_COMPILED: + case PVEC_CLOSURE: case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_RECORD: @@ -3813,17 +3813,17 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - if (! ((FIXNUMP (args[COMPILED_ARGLIST]) - || CONSP (args[COMPILED_ARGLIST]) - || NILP (args[COMPILED_ARGLIST])) - && STRINGP (args[COMPILED_BYTECODE]) - && !STRING_MULTIBYTE (args[COMPILED_BYTECODE]) - && VECTORP (args[COMPILED_CONSTANTS]) - && FIXNATP (args[COMPILED_STACK_DEPTH]))) + if (! ((FIXNUMP (args[CLOSURE_ARGLIST]) + || CONSP (args[CLOSURE_ARGLIST]) + || NILP (args[CLOSURE_ARGLIST])) + && STRINGP (args[CLOSURE_CODE]) + && !STRING_MULTIBYTE (args[CLOSURE_CODE]) + && VECTORP (args[CLOSURE_CONSTANTS]) + && FIXNATP (args[CLOSURE_STACK_DEPTH]))) error ("Invalid byte-code object"); /* Bytecode must be immovable. */ - pin_string (args[COMPILED_BYTECODE]); + pin_string (args[CLOSURE_CODE]); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3833,7 +3833,7 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ Lisp_Object val = Fvector (nargs, args); - XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED); + XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); return val; } @@ -3845,12 +3845,12 @@ usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */) (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object protofun = args[0]; - CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun); + CHECK_TYPE (CLOSUREP (protofun), Qbyte_code_function_p, protofun); /* Create a copy of the constant vector, filling it with the closure variables in the beginning. (The overwritten part should just contain placeholder values.) */ - Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS); + Lisp_Object proto_constvec = AREF (protofun, CLOSURE_CONSTANTS); ptrdiff_t constsize = ASIZE (proto_constvec); ptrdiff_t nvars = nargs - 1; if (nvars > constsize) @@ -3866,7 +3866,7 @@ usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */) struct Lisp_Vector *v = allocate_vectorlike (protosize, false); v->header = XVECTOR (protofun)->header; memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size); - v->contents[COMPILED_CONSTANTS] = constvec; + v->contents[CLOSURE_CONSTANTS] = constvec; return make_lisp_ptr (v, Lisp_Vectorlike); } @@ -6046,7 +6046,7 @@ purecopy (Lisp_Object obj) obj = make_lisp_hash_table (purecopy_hash_table (table)); } - else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj)) + else if (CLOSUREP (obj) || VECTORP (obj) || RECORDP (obj)) { struct Lisp_Vector *objp = XVECTOR (obj); ptrdiff_t nbytes = vector_nbytes (objp); @@ -6059,7 +6059,7 @@ purecopy (Lisp_Object obj) for (i = 0; i < size; i++) vec->contents[i] = purecopy (vec->contents[i]); /* Byte code strings must be pinned. */ - if (COMPILEDP (obj) && size >= 2 && STRINGP (vec->contents[1]) + if (CLOSUREP (obj) && size >= 2 && STRINGP (vec->contents[1]) && !STRING_MULTIBYTE (vec->contents[1])) pin_string (vec->contents[1]); XSETVECTOR (obj, vec); @@ -7050,6 +7050,7 @@ mark_frame (struct Lisp_Vector *ptr) mark_object (f->conversion.compose_region_start); mark_object (f->conversion.compose_region_end); mark_object (f->conversion.compose_region_overlay); + mark_object (f->conversion.field); for (tem = f->conversion.actions; tem; tem = tem->next) mark_object (tem->data); @@ -7421,7 +7422,9 @@ process_mark_stack (ptrdiff_t base_sp) /* 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. */ + a Lisp_Object var, or it's staticpro'd already, or it's + reachable from font_style_table which is also + staticpro'd. */ break; default: emacs_abort (); } @@ -8012,11 +8015,11 @@ symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) return (EQ (val, obj) || EQ (sym->u.s.function, obj) || (!NILP (sym->u.s.function) - && COMPILEDP (sym->u.s.function) - && EQ (AREF (sym->u.s.function, COMPILED_BYTECODE), obj)) + && CLOSUREP (sym->u.s.function) + && EQ (AREF (sym->u.s.function, CLOSURE_CODE), obj)) || (!NILP (val) - && COMPILEDP (val) - && EQ (AREF (val, COMPILED_BYTECODE), obj))); + && CLOSUREP (val) + && EQ (AREF (val, CLOSURE_CODE), obj))); } /* Find at most FIND_MAX symbols which have OBJ as their value or @@ -8314,6 +8317,8 @@ N should be nonnegative. */); 4, 4, "watch_gc_cons_percentage", {0}, lisp_h_Qnil}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); + DEFSYM (Qalloc, "alloc"); + DEFSYM (QCemergency, ":emergency"); } #ifdef HAVE_X_WINDOWS @@ -8341,7 +8346,7 @@ union enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE; enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE; enum Lisp_Bits Lisp_Bits; - enum Lisp_Compiled Lisp_Compiled; + enum Lisp_Closure Lisp_Closure; enum maxargs maxargs; enum MAX_ALLOCA MAX_ALLOCA; enum More_Lisp_Bits More_Lisp_Bits; diff --git a/src/android.c b/src/android.c index dcd5c6d99c7..d3b0bc21478 100644 --- a/src/android.c +++ b/src/android.c @@ -129,6 +129,13 @@ struct android_key_character_map jmethodID get_dead_char; }; +struct android_emacs_handle +{ + jclass class; + jmethodID destroy_handle; + jfieldID handle; +}; + /* The API level of the current device. */ static int android_api_level; @@ -177,7 +184,9 @@ static jfieldID emacs_gc_function, emacs_gc_clip_rects; static jfieldID emacs_gc_clip_x_origin, emacs_gc_clip_y_origin; static jfieldID emacs_gc_stipple, emacs_gc_clip_mask; static jfieldID emacs_gc_fill_style, emacs_gc_ts_origin_x; -static jfieldID emacs_gc_ts_origin_y; +static jfieldID emacs_gc_ts_origin_y, emacs_gc_line_style; +static jfieldID emacs_gc_line_width, emacs_gc_dash_offset; +static jfieldID emacs_gc_dashes; /* The constructor and one function. */ static jmethodID emacs_gc_constructor, emacs_gc_mark_dirty; @@ -212,6 +221,10 @@ static struct android_emacs_cursor cursor_class; /* Various methods associated with the KeyCharacterMap class. */ static struct android_key_character_map key_character_map_class; +/* Various methods and fields associated with the EmacsHandleObject + class. */ +static struct android_emacs_handle handle_class; + /* The time at which Emacs was installed, which also supplies the mtime of asset files. */ struct timespec emacs_installation_time; @@ -1618,7 +1631,7 @@ android_init_emacs_service (void) "Lorg/gnu/emacs/EmacsGC;II)V"); FIND_METHOD (ring_bell, "ringBell", "(I)V"); FIND_METHOD (query_tree, "queryTree", - "(Lorg/gnu/emacs/EmacsWindow;)[S"); + "(Lorg/gnu/emacs/EmacsWindow;)[J"); FIND_METHOD (get_screen_width, "getScreenWidth", "(Z)I"); FIND_METHOD (get_screen_height, "getScreenHeight", "(Z)I"); FIND_METHOD (detect_mouse, "detectMouse", "()Z"); @@ -1632,7 +1645,7 @@ android_init_emacs_service (void) FIND_METHOD (reset_ic, "resetIC", "(Lorg/gnu/emacs/EmacsWindow;I)V"); FIND_METHOD (open_content_uri, "openContentUri", - "([BZZZ)I"); + "(Ljava/lang/String;ZZZ)I"); FIND_METHOD (check_content_uri, "checkContentUri", "(Ljava/lang/String;ZZ)Z"); FIND_METHOD (query_battery, "queryBattery", "()[J"); @@ -1646,7 +1659,7 @@ android_init_emacs_service (void) FIND_METHOD (request_directory_access, "requestDirectoryAccess", "()I"); FIND_METHOD (get_document_trees, "getDocumentTrees", - "([B)[Ljava/lang/String;"); + "(Ljava/lang/String;)[Ljava/lang/String;"); FIND_METHOD (document_id_from_name, "documentIdFromName", "(Ljava/lang/String;Ljava/lang/String;" "[Ljava/lang/String;)I"); @@ -1690,6 +1703,8 @@ android_init_emacs_service (void) "requestStorageAccess", "()V"); FIND_METHOD (cancel_notification, "cancelNotification", "(Ljava/lang/String;)V"); + FIND_METHOD (relinquish_uri_rights, + "relinquishUriRights", "(Ljava/lang/String;)V"); #undef FIND_METHOD } @@ -1719,7 +1734,7 @@ android_init_emacs_pixmap (void) name, signature); \ eassert (pixmap_class.c_name); - FIND_METHOD (constructor_mutable, "<init>", "(SIII)V"); + FIND_METHOD (constructor_mutable, "<init>", "(III)V"); #undef FIND_METHOD } @@ -1872,7 +1887,7 @@ android_init_emacs_cursor (void) name, signature); \ eassert (cursor_class.c_name); - FIND_METHOD (constructor, "<init>", "(SI)V"); + FIND_METHOD (constructor, "<init>", "(I)V"); #undef FIND_METHOD } @@ -1902,6 +1917,42 @@ android_init_key_character_map (void) eassert (key_character_map_class.get_dead_char); } +static void +android_init_emacs_handle (void) +{ + jclass old; + + handle_class.class + = (*android_java_env)->FindClass (android_java_env, + "org/gnu/emacs/EmacsHandleObject"); + eassert (handle_class.class); + + old = handle_class.class; + handle_class.class + = (jclass) (*android_java_env)->NewGlobalRef (android_java_env, + (jobject) old); + ANDROID_DELETE_LOCAL_REF (old); + + if (!handle_class.class) + emacs_abort (); + +#define FIND_METHOD(c_name, name, signature) \ + handle_class.c_name \ + = (*android_java_env)->GetMethodID (android_java_env, \ + handle_class.class, \ + name, signature); \ + eassert (handle_class.c_name); + + FIND_METHOD (destroy_handle, "destroyHandle", "()V"); +#undef FIND_METHOD + + handle_class.handle + = (*android_java_env)->GetFieldID (android_java_env, + handle_class.class, + "handle", "J"); + eassert (handle_class.handle); +} + JNIEXPORT void JNICALL NATIVE_NAME (initEmacs) (JNIEnv *env, jobject object, jarray argv, jobject dump_file_object) @@ -1951,6 +2002,7 @@ NATIVE_NAME (initEmacs) (JNIEnv *env, jobject object, jarray argv, android_init_emacs_window (); android_init_emacs_cursor (); android_init_key_character_map (); + android_init_emacs_handle (); /* Set HOME to the app data directory. */ setenv ("HOME", android_files_dir, 1); @@ -2070,7 +2122,7 @@ NATIVE_NAME (onLowMemory) (JNIEnv *env, jobject object) JNIEXPORT jlong JNICALL NATIVE_NAME (sendConfigureNotify) (JNIEnv *env, jobject object, - jshort window, jlong time, + jlong window, jlong time, jint x, jint y, jint width, jint height) { @@ -2093,7 +2145,7 @@ NATIVE_NAME (sendConfigureNotify) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendKeyPress) (JNIEnv *env, jobject object, - jshort window, jlong time, + jlong window, jlong time, jint state, jint keycode, jint unicode_char) { @@ -2116,7 +2168,7 @@ NATIVE_NAME (sendKeyPress) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendKeyRelease) (JNIEnv *env, jobject object, - jshort window, jlong time, + jlong window, jlong time, jint state, jint keycode, jint unicode_char) { @@ -2139,7 +2191,7 @@ NATIVE_NAME (sendKeyRelease) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendFocusIn) (JNIEnv *env, jobject object, - jshort window, jlong time) + jlong window, jlong time) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2156,7 +2208,7 @@ NATIVE_NAME (sendFocusIn) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendFocusOut) (JNIEnv *env, jobject object, - jshort window, jlong time) + jlong window, jlong time) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2173,7 +2225,7 @@ NATIVE_NAME (sendFocusOut) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendWindowAction) (JNIEnv *env, jobject object, - jshort window, jint action) + jlong window, jint action) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2190,7 +2242,7 @@ NATIVE_NAME (sendWindowAction) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendEnterNotify) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2210,7 +2262,7 @@ NATIVE_NAME (sendEnterNotify) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendLeaveNotify) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2230,7 +2282,7 @@ NATIVE_NAME (sendLeaveNotify) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendMotionNotify) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2250,7 +2302,7 @@ NATIVE_NAME (sendMotionNotify) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendButtonPress) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time, jint state, jint button) { @@ -2273,7 +2325,7 @@ NATIVE_NAME (sendButtonPress) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendButtonRelease) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time, jint state, jint button) { @@ -2296,7 +2348,7 @@ NATIVE_NAME (sendButtonRelease) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendTouchDown) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time, jint pointer_id, jint flags) { @@ -2319,7 +2371,7 @@ NATIVE_NAME (sendTouchDown) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendTouchUp) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time, jint pointer_id, jint flags) { @@ -2342,7 +2394,7 @@ NATIVE_NAME (sendTouchUp) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendTouchMove) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time, jint pointer_id, jint flags) { @@ -2365,7 +2417,7 @@ NATIVE_NAME (sendTouchMove) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendWheel) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jlong time, jint state, jfloat x_delta, jfloat y_delta) { @@ -2389,7 +2441,7 @@ NATIVE_NAME (sendWheel) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendIconified) (JNIEnv *env, jobject object, - jshort window) + jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2405,7 +2457,7 @@ NATIVE_NAME (sendIconified) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendDeiconified) (JNIEnv *env, jobject object, - jshort window) + jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2421,7 +2473,7 @@ NATIVE_NAME (sendDeiconified) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendContextMenu) (JNIEnv *env, jobject object, - jshort window, jint menu_event_id, + jlong window, jint menu_event_id, jint menu_event_serial) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2440,7 +2492,7 @@ NATIVE_NAME (sendContextMenu) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendExpose) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jint width, jint height) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2461,7 +2513,7 @@ NATIVE_NAME (sendExpose) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendDndDrag) (JNIEnv *env, jobject object, - jshort window, jint x, jint y) + jlong window, jint x, jint y) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2481,7 +2533,7 @@ NATIVE_NAME (sendDndDrag) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendDndUri) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jstring string) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2518,7 +2570,7 @@ NATIVE_NAME (sendDndUri) (JNIEnv *env, jobject object, JNIEXPORT jlong JNICALL NATIVE_NAME (sendDndText) (JNIEnv *env, jobject object, - jshort window, jint x, jint y, + jlong window, jint x, jint y, jstring string) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -2643,6 +2695,13 @@ NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env, return !android_pass_multimedia_buttons_to_system; } +JNIEXPORT jint JNICALL +NATIVE_NAME (getQuitKeycode) (JNIEnv *env, jobject object) +{ + /* Likewise. */ + return (jint) android_quit_keycode; +} + JNIEXPORT jboolean JNICALL NATIVE_NAME (shouldForwardCtrlSpace) (JNIEnv *env, jobject object) { @@ -2700,7 +2759,6 @@ NATIVE_NAME (blitRect) (JNIEnv *env, jobject object, x2 = MAX (x2, 0); y2 = MAX (y2, 0); - if (x1 >= src_info.width || x1 >= dest_info.width) x1 = MIN (dest_info.width - 1, src_info.width - 1); @@ -2843,62 +2901,6 @@ NATIVE_NAME (setupSystemThread) (void) This means that every local reference must be explicitly destroyed with DeleteLocalRef. A helper macro is provided to do this. */ -struct android_handle_entry -{ - /* The type. */ - enum android_handle_type type; - - /* The handle. */ - jobject handle; -}; - -/* Table of handles MAX_HANDLE long. */ -struct android_handle_entry android_handles[USHRT_MAX]; - -/* The largest handle ID currently known, but subject to - wraparound. */ -static android_handle max_handle; - -/* Allocate a new, unused, handle identifier. If Emacs is out of - identifiers, return 0. */ - -static android_handle -android_alloc_id (void) -{ - android_handle handle; - - /* 0 is never a valid handle ID. */ - - if (!max_handle) - max_handle++; - - /* See if the handle is already occupied. */ - - if (android_handles[max_handle].handle) - { - /* Look for a fresh unoccupied handle. */ - - handle = max_handle; - max_handle++; - - while (handle != max_handle) - { - ++max_handle; - - /* Make sure the handle is valid. */ - if (!max_handle) - ++max_handle; - - if (!android_handles[max_handle].handle) - return max_handle++; - } - - return ANDROID_NONE; - } - - return max_handle++; -} - /* Destroy the specified handle and mark it as free on the Java side as well. */ @@ -2908,13 +2910,6 @@ android_destroy_handle (android_handle handle) static jclass old, class; static jmethodID method; - if (!android_handles[handle].handle) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Trying to destroy free handle!"); - emacs_abort (); - } - if (!class) { class @@ -2935,8 +2930,7 @@ android_destroy_handle (android_handle handle) ANDROID_DELETE_LOCAL_REF (old); } - (*android_java_env)->CallVoidMethod (android_java_env, - android_handles[handle].handle, + (*android_java_env)->CallVoidMethod (android_java_env, (jobject) handle, method); /* Just clear any exception thrown. If destroying the handle @@ -2945,76 +2939,7 @@ android_destroy_handle (android_handle handle) (*android_java_env)->ExceptionClear (android_java_env); /* Delete the global reference regardless of any error. */ - (*android_java_env)->DeleteGlobalRef (android_java_env, - android_handles[handle].handle); - android_handles[handle].handle = NULL; -} - -jobject -android_resolve_handle (android_handle handle, - enum android_handle_type type) -{ - if (!handle) - /* ANDROID_NONE. */ - return NULL; - - /* CheckJNI will normally ensure that the handle exists and is - the right type, but with a less informative error message. - Don't waste cycles doing our own checking here. */ - -#ifdef ENABLE_CHECKING - - if (!android_handles[handle].handle) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Trying to resolve free handle!"); - emacs_abort (); - } - - if (android_handles[handle].type != type) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Handle has wrong type!"); - emacs_abort (); - } - -#endif /* ENABLE_CHECKING */ - - return android_handles[handle].handle; -} - -static jobject -android_resolve_handle2 (android_handle handle, - enum android_handle_type type, - enum android_handle_type type2) -{ - if (!handle) - return NULL; - - /* CheckJNI will normally ensure that the handle exists and is - the right type, but with a less informative error message. - Don't waste cycles doing our own checking here. */ - -#ifdef ENABLE_CHECKING - - if (!android_handles[handle].handle) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Trying to resolve free handle!"); - emacs_abort (); - } - - if (android_handles[handle].type != type - && android_handles[handle].type != type2) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Handle has wrong type!"); - emacs_abort (); - } - -#endif /* ENABLE_CHECKING */ - - return android_handles[handle].handle; + (*android_java_env)->DeleteGlobalRef (android_java_env, (jobject) handle); } void @@ -3026,7 +2951,7 @@ android_change_window_attributes (android_window handle, jobject window; jint pixel; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); if (value_mask & ANDROID_CW_BACK_PIXEL) { @@ -3040,6 +2965,35 @@ android_change_window_attributes (android_window handle, } } +/* Return a reference to the local reference HANDLE suitable for + indefinite retention and save its value into HANDLE, deleting HANDLE, + or signal an error if such a reference cannot be allocated. */ + +static android_handle +android_globalize_reference (jobject handle) +{ + jobject global; + + /* Though Android 8.0 and later can support an unlimited number of + active local references, they remain inappropriate in threading + configurations for being local to the current thread. */ + + global = (*android_java_env)->NewGlobalRef (android_java_env, + handle); + (*android_java_env)->ExceptionClear (android_java_env); + ANDROID_DELETE_LOCAL_REF (handle); + + if (__builtin_expect (global == NULL, 0)) + error ("JNI global reference reserves exhausted"); + + /* Save the value of this handle into HANDLE. */ + (*android_java_env)->SetLongField (android_java_env, global, + handle_class.handle, + (jlong) global); + verify (sizeof (jlong) >= sizeof (intptr_t)); + return (intptr_t) global; +} + /* Create a new window with the given width, height and attributes. */ @@ -3053,16 +3007,10 @@ android_create_window (android_window parent, int x, int y, static jmethodID constructor; jobject object, parent_object, old; android_window window; - android_handle prev_max_handle; bool override_redirect; - parent_object = android_resolve_handle (parent, ANDROID_HANDLE_WINDOW); - - prev_max_handle = max_handle; - window = android_alloc_id (); + parent_object = android_resolve_handle (parent); - if (!window) - error ("Out of window handles!"); if (!class) { @@ -3072,7 +3020,7 @@ android_create_window (android_window parent, int x, int y, constructor = (*android_java_env)->GetMethodID (android_java_env, class, "<init>", - "(SLorg/gnu/emacs/EmacsWindow;" + "(Lorg/gnu/emacs/EmacsWindow;" "IIIIZ)V"); eassert (constructor != NULL); @@ -3089,28 +3037,12 @@ android_create_window (android_window parent, int x, int y, && attrs->override_redirect); object = (*android_java_env)->NewObject (android_java_env, class, - constructor, (jshort) window, - parent_object, (jint) x, (jint) y, + constructor, parent_object, + (jint) x, (jint) y, (jint) width, (jint) height, (jboolean) override_redirect); - if (!object) - { - (*android_java_env)->ExceptionClear (android_java_env); - - max_handle = prev_max_handle; - memory_full (0); - } - - android_handles[window].type = ANDROID_HANDLE_WINDOW; - android_handles[window].handle - = (*android_java_env)->NewGlobalRef (android_java_env, - object); - (*android_java_env)->ExceptionClear (android_java_env); - ANDROID_DELETE_LOCAL_REF (object); - - if (!android_handles[window].handle) - memory_full (0); - + android_exception_check (); + window = android_globalize_reference (object); android_change_window_attributes (window, value_mask, attrs); return window; } @@ -3128,13 +3060,6 @@ android_set_window_background (android_window window, unsigned long pixel) void android_destroy_window (android_window window) { - if (android_handles[window].type != ANDROID_HANDLE_WINDOW) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Trying to destroy something not a window!"); - emacs_abort (); - } - android_destroy_handle (window); } @@ -3182,7 +3107,7 @@ android_init_emacs_gc_class (void) emacs_gc_constructor = (*android_java_env)->GetMethodID (android_java_env, emacs_gc_class, - "<init>", "(S)V"); + "<init>", "()V"); eassert (emacs_gc_constructor); emacs_gc_mark_dirty @@ -3245,6 +3170,22 @@ android_init_emacs_gc_class (void) = (*android_java_env)->GetFieldID (android_java_env, emacs_gc_class, "ts_origin_y", "I"); + emacs_gc_line_style + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "line_style", "I"); + emacs_gc_line_width + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "line_width", "I"); + emacs_gc_dash_offset + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "dash_offset", "I"); + emacs_gc_dashes + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "dashes", "[I"); } struct android_gc * @@ -3252,14 +3193,12 @@ android_create_gc (enum android_gc_value_mask mask, struct android_gc_values *values) { struct android_gc *gc; - android_handle prev_max_handle; jobject object; android_init_emacs_gc_class (); gc = xmalloc (sizeof *gc); - prev_max_handle = max_handle; - gc->gcontext = android_alloc_id (); + gc->gcontext = 0; gc->foreground = 0; gc->background = 0xffffff; gc->clip_rects = NULL; @@ -3276,35 +3215,18 @@ android_create_gc (enum android_gc_value_mask mask, gc->stipple = ANDROID_NONE; gc->ts_x_origin = 0; gc->ts_y_origin = 0; - - if (!gc->gcontext) - { - xfree (gc); - error ("Out of GContext handles!"); - } + gc->line_style = ANDROID_LINE_SOLID; + gc->line_width = 0; + gc->dash_offset = 0; + gc->dashes = NULL; + gc->n_segments = 0; object = (*android_java_env)->NewObject (android_java_env, emacs_gc_class, - emacs_gc_constructor, - (jshort) gc->gcontext); - - if (!object) - { - (*android_java_env)->ExceptionClear (android_java_env); - - max_handle = prev_max_handle; - memory_full (0); - } - - android_handles[gc->gcontext].type = ANDROID_HANDLE_GCONTEXT; - android_handles[gc->gcontext].handle - = (*android_java_env)->NewGlobalRef (android_java_env, object); - (*android_java_env)->ExceptionClear (android_java_env); - ANDROID_DELETE_LOCAL_REF (object); - - if (!android_handles[gc->gcontext].handle) - memory_full (0); + emacs_gc_constructor); + android_exception_check (); + gc->gcontext = android_globalize_reference (object); android_change_gc (gc, mask, values); return gc; } @@ -3314,6 +3236,7 @@ android_free_gc (struct android_gc *gc) { android_destroy_handle (gc->gcontext); + xfree (gc->dashes); xfree (gc->clip_rects); xfree (gc); } @@ -3323,14 +3246,13 @@ android_change_gc (struct android_gc *gc, enum android_gc_value_mask mask, struct android_gc_values *values) { - jobject what, gcontext; + jobject what, gcontext, array; jboolean clip_changed; clip_changed = false; android_init_emacs_gc_class (); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + gcontext = android_resolve_handle (gc->gcontext); if (mask & ANDROID_GC_FOREGROUND) { @@ -3381,8 +3303,7 @@ android_change_gc (struct android_gc *gc, if (mask & ANDROID_GC_CLIP_MASK) { - what = android_resolve_handle (values->clip_mask, - ANDROID_HANDLE_PIXMAP); + what = android_resolve_handle (values->clip_mask); (*android_java_env)->SetObjectField (android_java_env, gcontext, emacs_gc_clip_mask, @@ -3403,8 +3324,7 @@ android_change_gc (struct android_gc *gc, if (mask & ANDROID_GC_STIPPLE) { - what = android_resolve_handle (values->stipple, - ANDROID_HANDLE_PIXMAP); + what = android_resolve_handle (values->stipple); (*android_java_env)->SetObjectField (android_java_env, gcontext, emacs_gc_stipple, @@ -3439,6 +3359,59 @@ android_change_gc (struct android_gc *gc, gc->ts_y_origin = values->ts_y_origin; } + if (mask & ANDROID_GC_LINE_STYLE) + { + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_line_style, + values->line_style); + gc->line_style = values->line_style; + } + + if (mask & ANDROID_GC_LINE_WIDTH) + { + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_line_width, + values->line_width); + gc->line_width = values->line_width; + } + + if (mask & ANDROID_GC_DASH_OFFSET) + { + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_dash_offset, + values->dash_offset); + gc->dash_offset = values->dash_offset; + } + + if (mask & ANDROID_GC_DASH_LIST) + { + /* Compare the new dash pattern with the old. */ + if (gc->dashes && gc->n_segments == 1 + && gc->dashes[0] == values->dash) + /* If they be identical, nothing needs to change. */ + mask &= ~ANDROID_GC_DASH_LIST; + else + { + if (gc->n_segments != 1) + gc->dashes = xrealloc (gc->dashes, sizeof *gc->dashes); + gc->n_segments = 1; + gc->dashes[0] = values->dash; + array = (*android_java_env)->NewIntArray (android_java_env, 1); + android_exception_check (); + (*android_java_env)->SetIntArrayRegion (android_java_env, + array, 0, 1, + (jint *) &values->dash); + (*android_java_env)->SetObjectField (android_java_env, + gcontext, + emacs_gc_dashes, + array); + ANDROID_DELETE_LOCAL_REF (array); + } + } + if (mask) { (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -3463,8 +3436,7 @@ android_set_clip_rectangles (struct android_gc *gc, int clip_x_origin, android_init_android_rect_class (); android_init_emacs_gc_class (); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + gcontext = android_resolve_handle (gc->gcontext); array = (*android_java_env)->NewObjectArray (android_java_env, n_clip_rects, @@ -3531,15 +3503,82 @@ android_set_clip_rectangles (struct android_gc *gc, int clip_x_origin, } void +android_set_dashes (struct android_gc *gc, int dash_offset, + int *dash_list, int n) +{ + int i; + jobject array, gcontext; + + gcontext = android_resolve_handle (gc->gcontext); + + if (n == gc->n_segments + && (!gc->dashes || !memcmp (gc->dashes, dash_list, + sizeof *dash_list * n))) + /* No change in the dash list. */ + goto set_offset; + + if (!n) + { + /* Reset the dash list to its initial empty state. */ + xfree (gc->dashes); + gc->dashes = NULL; + array = NULL; + } + else + { + /* If the size of the array has not changed, it can be reused. */ + + if (n != gc->n_segments) + { + gc->dashes = xrealloc (gc->dashes, sizeof *gc->dashes * n); + array = (*android_java_env)->NewIntArray (android_java_env, n); + android_exception_check (); + } + else + array = (*android_java_env)->GetObjectField (android_java_env, + gcontext, + emacs_gc_dashes); + + /* Copy the list of segments into both arrays. */ + for (i = 0; i < n; ++i) + gc->dashes[i] = dash_list[i]; + verify (sizeof (int) == sizeof (jint)); + (*android_java_env)->SetIntArrayRegion (android_java_env, + array, 0, n, + (jint *) dash_list); + } + + /* Replace the dash array in the GContext object if required. */ + if (n != gc->n_segments) + { + (*android_java_env)->SetObjectField (android_java_env, + gcontext, + emacs_gc_dashes, + array); + ANDROID_DELETE_LOCAL_REF (array); + } + + gc->n_segments = n; + + set_offset: + /* And the offset. */ + if (dash_offset != gc->dash_offset) + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_dash_offset, + dash_offset); + gc->dash_offset = dash_offset; +} + +void android_reparent_window (android_window w, android_window parent_handle, int x, int y) { jobject window, parent; jmethodID method; - window = android_resolve_handle (w, ANDROID_HANDLE_WINDOW); - parent = android_resolve_handle (parent_handle, - ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (w); + parent = android_resolve_handle (parent_handle); method = window_class.reparent_to; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, @@ -3553,7 +3592,7 @@ android_clear_window (android_window handle) { jobject window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, @@ -3568,7 +3607,7 @@ android_map_window (android_window handle) jobject window; jmethodID map_window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); map_window = window_class.map_window; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -3584,7 +3623,7 @@ android_unmap_window (android_window handle) jobject window; jmethodID unmap_window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); unmap_window = window_class.unmap_window; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -3601,7 +3640,7 @@ android_resize_window (android_window handle, unsigned int width, jobject window; jmethodID resize_window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); resize_window = window_class.resize_window; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -3619,7 +3658,7 @@ android_move_window (android_window handle, int x, int y) jobject window; jmethodID move_window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); move_window = window_class.move_window; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -3639,8 +3678,7 @@ android_swap_buffers (struct android_swap_info *swap_info, for (i = 0; i < num_windows; ++i) { - window = android_resolve_handle (swap_info[i].swap_window, - ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (swap_info[i].swap_window); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, window_class.class, @@ -3681,7 +3719,8 @@ android_get_gc_values (struct android_gc *gc, values->ts_y_origin = gc->ts_y_origin; /* Fields involving handles are not used by Emacs, and thus not - implemented */ + implemented. In addition, the size of GCClipMask and GCDashList is + not static, precluding their retrieval. */ } void @@ -3700,11 +3739,8 @@ android_fill_rectangle (android_drawable handle, struct android_gc *gc, { jobject drawable, gcontext; - drawable = android_resolve_handle2 (handle, - ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + drawable = android_resolve_handle (handle); + gcontext = android_resolve_handle (gc->gcontext); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, emacs_service, @@ -4225,286 +4261,6 @@ android_blit_copy (int src_x, int src_y, int width, int height, } -/* Xor a rectangle SRC_X, SRC_Y, WIDTH and HEIGHT from SRC, described - by SRC_INFO, to DST_X and DST_Y in DST, as described by DST_INFO. - - Ignore the alpha channel when computing the exclusive-or of the - destination pixel. - - If MASK is set, mask the source data using MASK_INFO, translating - it by GC->clip_x_origin and GC->clip_y_origin. MASK must be a - pixmap of depth 1. - - N.B. that currently only copies between bitmaps of depth 24 are - implemented. */ - -static void -android_blit_xor (int src_x, int src_y, int width, int height, - int dst_x, int dst_y, struct android_gc *gc, - unsigned char *src, AndroidBitmapInfo *src_info, - unsigned char *dst, AndroidBitmapInfo *dst_info, - unsigned char *mask, AndroidBitmapInfo *mask_info) -{ -#if 0 - uintptr_t start, end; - int mask_offset; - size_t pixel, offset, offset1; - unsigned char *src_current, *dst_current; - unsigned char *mask_current; - int overflow, temp, i; - bool backwards; - unsigned int *long_src, *long_dst; -#endif /* 0 */ - - /* Note that this alu hasn't been tested -- it probably does not - work! */ - emacs_abort (); - -#if 0 - /* Assert that the specified coordinates are within bounds. */ - eassert (src_x >= 0 && src_y >= 0 - && dst_x >= 0 && dst_y >= 0); - eassert (src_x + width <= src_info->width); - eassert (src_y + height <= src_info->height); - eassert (dst_x + width <= dst_info->width); - eassert (dst_y + height <= dst_info->height); - - /* Now check that each bitmap has the correct format. */ - eassert (src_info->format == dst_info->format - && src_info->format == ANDROID_BITMAP_FORMAT_RGBA_8888); - pixel = sizeof (unsigned int); - - /* Android doesn't have A1 bitmaps, so A8 is used to represent - packed bitmaps of depth 1. */ - eassert (!mask || mask_info->format == ANDROID_BITMAP_FORMAT_A_8); - - /* Calculate the address of the first pixel of the first row to be - copied in both src and dst. Compare them to determine the - direction in which the copy is to take place. */ - - overflow = ckd_mul (&start, src_y, src_info->stride); - overflow |= ckd_mul (&end, src_x, pixel); - overflow |= ckd_add (&start, (uintptr_t) src, start); - - if (overflow) - return; - - src_current = (unsigned char *) start; - - overflow = ckd_mul (&start, dst_y, src_info->stride); - overflow |= ckd_mul (&end, dst_x, pixel); - overflow |= ckd_add (&start, (uintptr_t) dst, start); - - if (overflow) - return; - - dst_current = (unsigned char *) start; - backwards = false; - - /* Now see if copying should proceed from the bottom up. */ - - if (src == dst && dst_current >= src_current) - { - backwards = true; - - /* Walk src and dst from bottom to top, in order to avoid - overlap. Calculate the coordinate of the last pixel of the - last row in both src and dst. */ - - overflow = ckd_mul (&start, src_y + height - 1, - src_info->stride); - if (mask) /* If a mask is set, put the pointers before the end - of the row. */ - overflow |= ckd_mul (&end, src_x + width - 1, pixel); - else - overflow |= ckd_mul (&end, src_x, pixel); - overflow |= ckd_add (&start, start, end); - overflow |= ckd_add (&start, (uintptr_t) src, start); - - if (overflow) - return; - - src_current = (unsigned char *) start; - - overflow = ckd_mul (&start, dst_y + height - 1, - dst_info->stride); - if (mask) /* If a mask is set, put the pointers before the end - of the row. */ - overflow |= ckd_mul (&end, dst_x + width - 1, pixel); - else - overflow |= ckd_mul (&end, dst_x, pixel); - overflow |= ckd_add (&start, start, end); - overflow |= ckd_add (&start, (uintptr_t) dst, start); - - if (overflow) - return; - - dst_current = (unsigned char *) start; - } - - if (!mask) - { - /* Change the direction of the copy depending on how SRC and DST - overlap. */ - - for (i = 0; i < height; ++i) - { - if (backwards) - { - for (i = width - 1; i <= 0; --i) - (((unsigned int *) dst_current)[i]) - /* Keep the alpha channel intact. */ - ^= (((unsigned int *) src_current)[i]) & 0xffffff; - - /* Proceed to the last row. */ - src_current -= src_info->stride; - dst_current -= dst_info->stride; - } - else - { - for (i = 0; i < width; ++i) - (((unsigned int *) dst_current)[i]) - /* Keep the alpha channel intact. */ - ^= (((unsigned int *) src_current)[i]) & 0xffffff; - - /* Proceed to the next row. */ - src_current += src_info->stride; - dst_current += dst_info->stride; - } - } - } - else - { - /* Adjust the source and destination Y. The start is MAX - (dst_y, gc->clip_y_origin); the difference between that value - and dst_y is the offset to apply to src_y. */ - - temp = dst_y; - dst_y = MAX (dst_y, gc->clip_y_origin); - src_y += dst_y - temp; - height -= dst_y - temp; - - /* Verify that the bounds are correct. */ - eassert (dst_y + height - <= gc->clip_y_origin + mask_info->height); - eassert (dst_y >= gc->clip_y_origin); - - /* There is a mask. For each scan line... */ - - if (backwards) - { - /* Calculate the number of pixels at the end of the - mask. */ - - mask_offset = dst_x + width; - mask_offset -= mask_info->width + gc->clip_x_origin; - - if (mask_info < 0) - mask_info = 0; - - /* Calculate the last column of the mask that will be - consulted. */ - - temp = dst_x - gc->clip_x_origin; - temp += MIN (mask_info->width - temp, - width - mask_offset); - - if (temp < 0) - return; - - /* Now calculate the last row of the mask that will be - consulted. */ - i = dst_y - gc->clip_y_origin + height; - - /* Turn both into offsets. */ - - if (ckd_mul (&offset, temp, pixel) - || ckd_mul (&offset1, i, mask_info->stride) - || ckd_add (&offset, offset, offset1) - || ckd_add (&start, (uintptr_t) mask, offset)) - return; - - mask = mask_current = (unsigned char *) start; - - for (i = 0; i < height; ++i) - { - /* Skip backwards past the end of the mask. */ - - long_src = (unsigned int *) (src_current - mask_offset * pixel); - long_dst = (unsigned int *) (dst_current - mask_offset * pixel); - mask = mask_current; - - /* For each pixel covered by the mask... */ - temp = MIN (mask_info->width - temp, width - mask_offset); - while (temp--) - /* XOR the source to the destination, masked by the - mask. */ - *long_dst-- ^= ((*(long_src--) & (0u - (*(mask--) & 1))) - & 0xffffff); - - /* Return to the last row. */ - src_current -= src_info->stride; - dst_current -= dst_info->stride; - mask_current -= mask_info->stride; - } - } - else - { - /* Calculate the first column of the mask that will be - consulted. */ - - mask_offset = dst_x - gc->clip_x_origin; - - /* Adjust the mask by that much. */ - - if (mask_offset > 0) - mask += mask_offset; - else - { - /* Offset src and dst by the mask offset. */ - src_current += -mask_offset * pixel; - dst_current += -mask_offset * pixel; - width -= mask_offset; - } - - /* Now move mask to the position of the first row. */ - - mask += gc->clip_y_origin * mask_info->stride; - - for (i = 0; i < height; ++i) - { - long_src = (unsigned int *) src_current; - long_dst = (unsigned int *) dst_current; - mask_current = mask; - - if (mask_offset > 0) - { - /* Copy bytes according to the mask. */ - temp = MIN (mask_info->width - mask_offset, width); - while (temp--) - *long_dst++ ^= ((*(long_src++) - & (0u - (*(mask_current++) & 1))) - & 0xffffff); - } - else - { - /* Copy bytes according to the mask. */ - temp = MIN (mask_info->width, width); - while (temp--) - *long_dst++ = ((*(long_src++) - & (0u - (*(mask_current++) & 1))) - & 0xffffff); - } - - src_current += src_info->stride; - dst_current += dst_info->stride; - mask += mask_info->stride; - } - } - } -#endif /* 0 */ -} - void android_copy_area (android_drawable src, android_drawable dest, struct android_gc *gc, int src_x, int src_y, @@ -4607,10 +4363,10 @@ android_copy_area (android_drawable src, android_drawable dest, do_blit = android_blit_copy; break; - case ANDROID_GC_XOR: - do_blit = android_blit_xor; - break; - + /* case ANDROID_GC_INVERT: */ + /* do_blit = android_blit_invert; */ + /* A GC with its operation set to ANDROID_GC_INVERT is never given + to CopyArea. */ default: emacs_abort (); } @@ -4651,7 +4407,9 @@ android_copy_area (android_drawable src, android_drawable dest, /* Now damage the destination drawable accordingly, should it be a window. */ - if (android_handles[dest].type == ANDROID_HANDLE_WINDOW) + if ((*android_java_env)->IsInstanceOf (android_java_env, + (jobject) dest, + window_class.class)) android_damage_window (dest, &bounds); fail2: @@ -4697,11 +4455,8 @@ android_fill_polygon (android_drawable drawable, struct android_gc *gc, jobject point, drawable_object, gcontext; int i; - drawable_object = android_resolve_handle2 (drawable, - ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + drawable_object = android_resolve_handle (drawable); + gcontext = android_resolve_handle (gc->gcontext); array = (*android_java_env)->NewObjectArray (android_java_env, npoints, @@ -4739,11 +4494,8 @@ android_draw_rectangle (android_drawable handle, struct android_gc *gc, { jobject drawable, gcontext; - drawable = android_resolve_handle2 (handle, - ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + drawable = android_resolve_handle (handle); + gcontext = android_resolve_handle (gc->gcontext); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, emacs_service, @@ -4764,11 +4516,8 @@ android_draw_point (android_drawable handle, struct android_gc *gc, { jobject drawable, gcontext; - drawable = android_resolve_handle2 (handle, - ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + drawable = android_resolve_handle (handle); + gcontext = android_resolve_handle (gc->gcontext); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, emacs_service, @@ -4788,11 +4537,8 @@ android_draw_line (android_drawable handle, struct android_gc *gc, { jobject drawable, gcontext; - drawable = android_resolve_handle2 (handle, - ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); - gcontext = android_resolve_handle (gc->gcontext, - ANDROID_HANDLE_GCONTEXT); + drawable = android_resolve_handle (handle); + gcontext = android_resolve_handle (gc->gcontext); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, emacs_service, @@ -4811,41 +4557,15 @@ android_pixmap android_create_pixmap (unsigned int width, unsigned int height, int depth) { - android_handle prev_max_handle; jobject object; - android_pixmap pixmap; - - /* First, allocate the pixmap handle. */ - prev_max_handle = max_handle; - pixmap = android_alloc_id (); - - if (!pixmap) - error ("Out of pixmap handles!"); object = (*android_java_env)->NewObject (android_java_env, pixmap_class.class, pixmap_class.constructor_mutable, - (jshort) pixmap, (jint) width, (jint) height, (jint) depth); - - if (!object) - { - (*android_java_env)->ExceptionClear (android_java_env); - max_handle = prev_max_handle; - memory_full (0); - } - - android_handles[pixmap].type = ANDROID_HANDLE_PIXMAP; - android_handles[pixmap].handle - = (*android_java_env)->NewGlobalRef (android_java_env, object); - (*android_java_env)->ExceptionClear (android_java_env); - ANDROID_DELETE_LOCAL_REF (object); - - if (!android_handles[pixmap].handle) - memory_full (0); - - return pixmap; + android_exception_check (); + return android_globalize_reference (object); } void @@ -4866,7 +4586,7 @@ android_clear_area (android_window handle, int x, int y, { jobject window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, @@ -4880,8 +4600,8 @@ android_pixmap android_create_bitmap_from_data (char *bits, unsigned int width, unsigned int height) { - return android_create_pixmap_from_bitmap_data (bits, 1, 0, - width, height, 1); + return android_create_pixmap_from_bitmap_data (bits, width, height, + 1, 0, 1); } struct android_image * @@ -5018,8 +4738,7 @@ android_get_image (android_drawable handle, unsigned char *data1, *data2; int i, x; - drawable = android_resolve_handle2 (handle, ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); + drawable = android_resolve_handle (handle); /* Look up the drawable and get the bitmap corresponding to it. Then, lock the bitmap's bits. */ @@ -5153,7 +4872,7 @@ android_put_image (android_pixmap handle, struct android_image *image) unsigned char *data_1, *data_2; int i, x; - drawable = android_resolve_handle (handle, ANDROID_HANDLE_PIXMAP); + drawable = android_resolve_handle (handle); /* Look up the drawable and get the bitmap corresponding to it. Then, lock the bitmap's bits. */ @@ -5255,7 +4974,7 @@ android_set_input_focus (android_window handle, unsigned long time) jobject window; jmethodID make_input_focus; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); make_input_focus = window_class.make_input_focus; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -5272,7 +4991,7 @@ android_raise_window (android_window handle) jobject window; jmethodID raise; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); raise = window_class.raise; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -5288,7 +5007,7 @@ android_lower_window (android_window handle) jobject window; jmethodID lower; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); lower = window_class.lower; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -5305,7 +5024,7 @@ android_reconfigure_wm_window (android_window handle, { jobject sibling, window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); if (!(value_mask & ANDROID_CW_STACK_MODE)) return; @@ -5317,8 +5036,7 @@ android_reconfigure_wm_window (android_window handle, sibling = NULL; if (value_mask & ANDROID_CW_SIBLING) - sibling = android_resolve_handle (values->sibling, - ANDROID_HANDLE_WINDOW); + sibling = android_resolve_handle (values->sibling); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, @@ -5338,10 +5056,10 @@ android_query_tree (android_window handle, android_window *root_return, jobject window, array; jsize nelements, i; android_window *children; - jshort *shorts; + jlong *longs; jmethodID method; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); /* window can be NULL, so this is a service method. */ method = service_class.query_tree; @@ -5361,25 +5079,25 @@ android_query_tree (android_window handle, android_window *root_return, /* Now fill in the children. */ children = xnmalloc (nelements - 1, sizeof *children); - shorts - = (*android_java_env)->GetShortArrayElements (android_java_env, array, - NULL); - android_exception_check_nonnull (shorts, array); + longs + = (*android_java_env)->GetLongArrayElements (android_java_env, array, + NULL); + android_exception_check_nonnull (longs, array); for (i = 1; i < nelements; ++i) /* Subtract one from the index into children, since the parent is not included. */ - children[i - 1] = shorts[i]; + children[i - 1] = longs[i]; /* Finally, return the parent and other values. */ *root_return = 0; - *parent_return = shorts[0]; + *parent_return = longs[0]; *children_return = children; *nchildren_return = nelements - 1; /* Release the array contents. */ - (*android_java_env)->ReleaseShortArrayElements (android_java_env, array, - shorts, JNI_ABORT); + (*android_java_env)->ReleaseLongArrayElements (android_java_env, array, + longs, JNI_ABORT); ANDROID_DELETE_LOCAL_REF (array); return 1; @@ -5398,7 +5116,7 @@ android_get_geometry (android_window handle, jmethodID get_geometry; jint *ints; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); get_geometry = window_class.get_window_geometry; window_geometry @@ -5460,7 +5178,7 @@ android_translate_coordinates (android_window src, int x, jmethodID method; jint *ints; - window = android_resolve_handle (src, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (src); method = window_class.translate_coordinates; coordinates = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env, @@ -5628,51 +5346,44 @@ android_wc_lookup_string (android_key_pressed_event *event, /* Now look up the window. */ rc = 0; - if (!android_handles[event->window].handle - || (android_handles[event->window].type - != ANDROID_HANDLE_WINDOW)) + window = android_resolve_handle (event->window); + string + = (*env)->CallNonvirtualObjectMethod (env, window, + window_class.class, + window_class.lookup_string, + (jint) event->serial); + android_exception_check (); + + if (!string) status = ANDROID_LOOKUP_NONE; else { - window = android_handles[event->window].handle; - string - = (*env)->CallNonvirtualObjectMethod (env, window, - window_class.class, - window_class.lookup_string, - (jint) event->serial); - android_exception_check (); - - if (!string) - status = ANDROID_LOOKUP_NONE; - else - { - /* Now return this input method string. */ - characters = (*env)->GetStringChars (env, string, NULL); - android_exception_check_nonnull ((void *) characters, string); + /* Now return this input method string. */ + characters = (*env)->GetStringChars (env, string, NULL); + android_exception_check_nonnull ((void *) characters, string); - /* Establish the size of the the string. */ - size = (*env)->GetStringLength (env, string); + /* Establish the size of the the string. */ + size = (*env)->GetStringLength (env, string); - /* Copy over the string data. */ - for (i = 0; i < MIN ((unsigned int) wchars_buffer, size); ++i) - buffer_return[i] = characters[i]; + /* Copy over the string data. */ + for (i = 0; i < MIN ((unsigned int) wchars_buffer, size); ++i) + buffer_return[i] = characters[i]; - if (i < size) - status = ANDROID_BUFFER_OVERFLOW; - else - status = ANDROID_LOOKUP_CHARS; + if (i < size) + status = ANDROID_BUFFER_OVERFLOW; + else + status = ANDROID_LOOKUP_CHARS; - /* Return the number of characters that should have been - written. */ + /* Return the number of characters that should have been + written. */ - if (size > INT_MAX) - rc = INT_MAX; - else - rc = size; + if (size > INT_MAX) + rc = INT_MAX; + else + rc = size; - (*env)->ReleaseStringChars (env, string, characters); - ANDROID_DELETE_LOCAL_REF (string); - } + (*env)->ReleaseStringChars (env, string, characters); + ANDROID_DELETE_LOCAL_REF (string); } *status_return = status; @@ -5706,8 +5417,7 @@ android_lock_bitmap (android_drawable drawable, jobject object, bitmap; void *data; - object = android_resolve_handle2 (drawable, ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_PIXMAP); + object = android_resolve_handle (drawable); /* Look up the drawable and get the bitmap corresponding to it. Then, lock the bitmap's bits. */ @@ -5761,7 +5471,7 @@ android_damage_window (android_drawable handle, { jobject drawable; - drawable = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + drawable = android_resolve_handle (handle); /* Post the damage to the drawable. */ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -5882,7 +5592,7 @@ android_set_dont_focus_on_map (android_window handle, jmethodID method; jobject window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); method = window_class.set_dont_focus_on_map; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, @@ -5899,7 +5609,7 @@ android_set_dont_accept_focus (android_window handle, jmethodID method; jobject window; - window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (handle); method = window_class.set_dont_accept_focus; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window, @@ -5978,7 +5688,7 @@ android_toggle_on_screen_keyboard (android_window window, bool show) jobject object; jmethodID method; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); method = window_class.toggle_on_screen_keyboard; /* Now display the on screen keyboard. */ @@ -5992,40 +5702,22 @@ android_toggle_on_screen_keyboard (android_window window, bool show) -#if defined __clang_major__ && __clang_major__ < 5 -# define HAS_BUILTIN_TRAP 0 -#elif 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__)) -# define HAS_BUILTIN_TRAP 1 -#elif defined __has_builtin -# define HAS_BUILTIN_TRAP __has_builtin (__builtin_trap) -#else /* !__has_builtin */ -# define HAS_BUILTIN_TRAP 0 -#endif /* defined __clang_major__ && __clang_major__ < 5 */ - /* emacs_abort implementation for Android. This logs a stack trace. */ void emacs_abort (void) { -#ifndef HAS_BUILTIN_TRAP volatile char *foo; -#endif /* !HAS_BUILTIN_TRAP */ __android_log_print (ANDROID_LOG_FATAL, __func__, "emacs_abort called, please review the following" " stack trace"); -#ifndef HAS_BUILTIN_TRAP /* Induce a NULL pointer dereference to make debuggerd generate a tombstone. */ foo = NULL; *foo = '\0'; -#else /* HAS_BUILTIN_TRAP */ - /* Crash through __builtin_trap instead. This appears to more - uniformly elicit crash reports from debuggerd. */ - __builtin_trap (); -#endif /* !HAS_BUILTIN_TRAP */ abort (); } @@ -6257,11 +5949,7 @@ android_build_jstring (const char *text) if global_foo cannot be allocated, and after the global reference is created. */ -#if __GNUC__ >= 3 #define likely(cond) __builtin_expect (cond, 1) -#else /* __GNUC__ < 3 */ -#define likely(cond) (cond) -#endif /* __GNUC__ >= 3 */ /* Check for JNI exceptions and call memory_full in that situation. */ @@ -6973,7 +6661,7 @@ android_recreate_activity (android_window window) jobject object; jmethodID method; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); method = window_class.recreate_activity; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, object, @@ -7338,7 +7026,7 @@ android_update_ic (android_window window, ptrdiff_t selection_start, { jobject object; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, emacs_service, @@ -7375,7 +7063,7 @@ android_reset_ic (android_window window, enum android_ic_mode mode) { jobject object; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, emacs_service, @@ -7397,7 +7085,7 @@ android_update_extracted_text (android_window window, void *text, jobject object; jmethodID method; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); method = service_class.update_extracted_text; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -7431,7 +7119,7 @@ android_update_cursor_anchor_info (android_window window, float x, jobject object; jmethodID method; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); method = service_class.update_cursor_anchor_info; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -7466,7 +7154,7 @@ android_set_fullscreen (android_window window, bool fullscreen) if (android_api_level < 16) return 1; - object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); + object = android_resolve_handle (window); (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, object, @@ -7484,40 +7172,15 @@ android_set_fullscreen (android_window window, bool fullscreen) android_cursor android_create_font_cursor (enum android_cursor_shape shape) { - android_cursor id; - short prev_max_handle; jobject object; - /* First, allocate the cursor handle. */ - prev_max_handle = max_handle; - id = android_alloc_id (); - - if (!id) - error ("Out of cursor handles!"); - /* Next, create the cursor. */ object = (*android_java_env)->NewObject (android_java_env, cursor_class.class, cursor_class.constructor, - (jshort) id, (jint) shape); - if (!object) - { - (*android_java_env)->ExceptionClear (android_java_env); - max_handle = prev_max_handle; - memory_full (0); - } - - android_handles[id].type = ANDROID_HANDLE_CURSOR; - android_handles[id].handle - = (*android_java_env)->NewGlobalRef (android_java_env, object); - (*android_java_env)->ExceptionClear (android_java_env); - ANDROID_DELETE_LOCAL_REF (object); - - if (!android_handles[id].handle) - memory_full (0); - - return id; + android_exception_check (); + return android_globalize_reference (object); } void @@ -7526,8 +7189,8 @@ android_define_cursor (android_window window, android_cursor cursor) jobject window1, cursor1; jmethodID method; - window1 = android_resolve_handle (window, ANDROID_HANDLE_WINDOW); - cursor1 = android_resolve_handle (cursor, ANDROID_HANDLE_CURSOR); + window1 = android_resolve_handle (window); + cursor1 = android_resolve_handle (cursor); method = window_class.define_cursor; (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -7540,13 +7203,6 @@ android_define_cursor (android_window window, android_cursor cursor) void android_free_cursor (android_cursor cursor) { - if (android_handles[cursor].type != ANDROID_HANDLE_CURSOR) - { - __android_log_print (ANDROID_LOG_ERROR, __func__, - "Trying to destroy something not a CURSOR!"); - emacs_abort (); - } - android_destroy_handle (cursor); } diff --git a/src/android.h b/src/android.h index 2ca3d7e1446..a582a9b7dff 100644 --- a/src/android.h +++ b/src/android.h @@ -53,6 +53,22 @@ extern char *android_user_full_name (struct passwd *); +/* Structure describing the android.os.ParcelFileDescriptor class used + to wrap file descriptors sent over IPC. */ + +struct android_parcel_file_descriptor_class +{ + jclass class; + jmethodID close; + jmethodID get_fd; + jmethodID detach_fd; +}; + +/* The ParcelFileDescriptor class. */ +extern struct android_parcel_file_descriptor_class fd_class; + +extern void android_init_fd_class (JNIEnv *); + /* File I/O operations. Many of these are defined in androidvfs.c. */ @@ -85,16 +101,9 @@ extern ssize_t android_readlinkat (int, const char *restrict, char *restrict, extern double android_pixel_density_x, android_pixel_density_y; extern double android_scaled_pixel_density; -enum android_handle_type - { - ANDROID_HANDLE_WINDOW, - ANDROID_HANDLE_GCONTEXT, - ANDROID_HANDLE_PIXMAP, - ANDROID_HANDLE_CURSOR, - }; +verify (sizeof (android_handle) == sizeof (jobject)); +#define android_resolve_handle(handle) ((jobject) (handle)) -extern jobject android_resolve_handle (android_handle, - enum android_handle_type); extern unsigned char *android_lock_bitmap (android_drawable, AndroidBitmapInfo *, jobject *); @@ -303,6 +312,7 @@ struct android_emacs_service jmethodID external_storage_available; jmethodID request_storage_access; jmethodID cancel_notification; + jmethodID relinquish_uri_rights; }; extern JNIEnv *android_java_env; diff --git a/src/androidfns.c b/src/androidfns.c index 83cf81c1f07..df425e5779e 100644 --- a/src/androidfns.c +++ b/src/androidfns.c @@ -1202,7 +1202,10 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - return Qt; + struct android_display_info *dpyinfo; + + dpyinfo = check_android_display_info (terminal); + return dpyinfo->n_planes > 8 ? Qt : Qnil; } DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, @@ -1210,7 +1213,11 @@ DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - return Qnil; + struct android_display_info *dpyinfo; + + dpyinfo = check_android_display_info (terminal); + return (dpyinfo->n_planes > 1 && dpyinfo->n_planes <= 8 + ? Qt : Qnil); } DEFUN ("x-display-pixel-width", Fx_display_pixel_width, @@ -1345,7 +1352,12 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - check_android_display_info (terminal); + struct android_display_info *dpyinfo; + + dpyinfo = check_android_display_info (terminal); + + if (dpyinfo->n_planes < 24) + return Qstatic_gray; return Qtrue_color; } @@ -1805,7 +1817,16 @@ Android, so there is no equivalent of `x-open-connection'. */) terminal = Qnil; if (x_display_list) - XSETTERMINAL (terminal, x_display_list->terminal); + { + XSETTERMINAL (terminal, x_display_list->terminal); + + /* Update the display's bit depth from + `android_display_planes'. */ + x_display_list->n_planes + = (android_display_planes > 8 + ? 24 : (android_display_planes > 1 + ? android_display_planes : 1)); + } return terminal; #endif @@ -3146,7 +3167,7 @@ for more details about these values. */) -/* Directory access requests. */ +/* SAF directory access management. */ DEFUN ("android-request-directory-access", Fandroid_request_directory_access, Sandroid_request_directory_access, 0, 0, "", @@ -3479,6 +3500,7 @@ syms_of_androidfns (void) { /* Miscellaneous symbols used by some functions here. */ DEFSYM (Qtrue_color, "true-color"); + DEFSYM (Qstatic_gray, "static-color"); DEFSYM (Qwhen_mapped, "when-mapped"); DEFVAR_LISP ("x-pointer-shape", Vx_pointer_shape, diff --git a/src/androidfont.c b/src/androidfont.c index 5fd3018b6d4..20a18327ff8 100644 --- a/src/androidfont.c +++ b/src/androidfont.c @@ -657,10 +657,8 @@ androidfont_draw (struct glyph_string *s, int from, int to, verify (sizeof (unsigned int) == sizeof (jint)); info = (struct androidfont_info *) s->font; - gcontext = android_resolve_handle (s->gc->gcontext, - ANDROID_HANDLE_GCONTEXT); - drawable = android_resolve_handle (FRAME_ANDROID_DRAWABLE (s->f), - ANDROID_HANDLE_WINDOW); + gcontext = android_resolve_handle (s->gc->gcontext); + drawable = android_resolve_handle (FRAME_ANDROID_DRAWABLE (s->f)); chars = (*android_java_env)->NewIntArray (android_java_env, to - from); android_exception_check (); diff --git a/src/androidgui.h b/src/androidgui.h index f941c7cc577..79e42c7947c 100644 --- a/src/androidgui.h +++ b/src/androidgui.h @@ -19,6 +19,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef _ANDROID_GUI_H_ #define _ANDROID_GUI_H_ +#include <stdint.h> + struct android_char_struct { int rbearing; @@ -30,7 +32,8 @@ struct android_char_struct typedef struct android_char_struct XCharStruct; -typedef unsigned short android_handle; +/* Handles are but JNI handles cast to intptr_t. */ +typedef intptr_t android_handle; typedef android_handle android_pixmap, Emacs_Pixmap; typedef android_handle android_window, Emacs_Window; @@ -56,7 +59,7 @@ struct android_point enum android_gc_function { ANDROID_GC_COPY = 0, - ANDROID_GC_XOR = 1, + ANDROID_GC_INVERT = 1, }; enum android_gc_value_mask @@ -71,6 +74,10 @@ enum android_gc_value_mask ANDROID_GC_FILL_STYLE = (1 << 7), ANDROID_GC_TILE_STIP_X_ORIGIN = (1 << 8), ANDROID_GC_TILE_STIP_Y_ORIGIN = (1 << 9), + ANDROID_GC_LINE_STYLE = (1 << 10), + ANDROID_GC_LINE_WIDTH = (1 << 11), + ANDROID_GC_DASH_LIST = (1 << 12), + ANDROID_GC_DASH_OFFSET = (1 << 13), }; enum android_fill_style @@ -79,6 +86,12 @@ enum android_fill_style ANDROID_FILL_OPAQUE_STIPPLED = 1, }; +enum android_line_style + { + ANDROID_LINE_SOLID = 0, + ANDROID_LINE_ON_OFF_DASH = 1, + }; + enum android_window_value_mask { ANDROID_CW_BACK_PIXEL = (1 << 1), @@ -114,6 +127,18 @@ struct android_gc_values /* The tile-stipple X and Y origins. */ int ts_x_origin, ts_y_origin; + + /* The line style. */ + enum android_line_style line_style; + + /* The line width. */ + int line_width; + + /* Offset in pixels into the dash pattern specified below. */ + int dash_offset; + + /* One integer providing both segments of a even-odd dash pattern. */ + int dash; }; /* X-like graphics context structure. This is implemented in @@ -152,6 +177,18 @@ struct android_gc /* The tile-stipple X and Y origins. */ int ts_x_origin, ts_y_origin; + + /* The line style. */ + enum android_line_style line_style; + + /* The line width. */ + int line_width; + + /* Offset in pixels into the dash pattern specified below. */ + int dash_offset; + + /* The segments of an even/odd dash pattern. */ + int *dashes, n_segments; }; enum android_swap_action @@ -675,6 +712,7 @@ extern void android_set_clip_rectangles (struct android_gc *, int, int, struct android_rectangle *, int); +extern void android_set_dashes (struct android_gc *, int, int *, int); extern void android_change_gc (struct android_gc *, enum android_gc_value_mask, struct android_gc_values *); diff --git a/src/androidmenu.c b/src/androidmenu.c index 362d500ac1a..7d24087fa87 100644 --- a/src/androidmenu.c +++ b/src/androidmenu.c @@ -488,8 +488,7 @@ android_menu_show (struct frame *f, int x, int y, int menuflags, unbind_to (count1, Qnil); /* Now, display the context menu. */ - window = android_resolve_handle (FRAME_ANDROID_WINDOW (f), - ANDROID_HANDLE_WINDOW); + window = android_resolve_handle (FRAME_ANDROID_WINDOW (f)); rc = (*env)->CallNonvirtualBooleanMethod (env, context_menu, menu_class.class, menu_class.display, diff --git a/src/androidselect.c b/src/androidselect.c index 2f6114d0fcb..7c93607848a 100644 --- a/src/androidselect.c +++ b/src/androidselect.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <assert.h> #include <minmax.h> #include <unistd.h> +#include <dlfcn.h> #include <boot-time.h> #include <sys/types.h> @@ -98,9 +99,10 @@ android_init_emacs_clipboard (void) FIND_METHOD (clipboard_exists, "clipboardExists", "()Z"); FIND_METHOD (get_clipboard, "getClipboard", "()[B"); FIND_METHOD (get_clipboard_targets, "getClipboardTargets", - "()[[B"); + "()[Ljava/lang/String;"); FIND_METHOD (get_clipboard_data, "getClipboardData", - "([B)[J"); + "(Ljava/lang/String;)Landroid/content/res/" + "AssetFileDescriptor;"); clipboard_class.make_clipboard = (*android_java_env)->GetStaticMethodID (android_java_env, @@ -282,11 +284,11 @@ Value is a list of MIME types as strings, each defining a single extra data type available from the clipboard. */) (void) { - jarray bytes_array; - jbyteArray bytes; + jarray all_targets; + jstring string; jmethodID method; - size_t length, length1, i; - jbyte *data; + size_t length, i; + const char *data; Lisp_Object targets, tem; if (!android_init_gui) @@ -295,44 +297,42 @@ data type available from the clipboard. */) targets = Qnil; block_input (); method = clipboard_class.get_clipboard_targets; - bytes_array = (*android_java_env)->CallObjectMethod (android_java_env, + all_targets = (*android_java_env)->CallObjectMethod (android_java_env, clipboard, method); android_exception_check (); - if (!bytes_array) + if (!all_targets) goto fail; length = (*android_java_env)->GetArrayLength (android_java_env, - bytes_array); + all_targets); for (i = 0; i < length; ++i) { /* Retrieve the MIME type. */ - bytes + string = (*android_java_env)->GetObjectArrayElement (android_java_env, - bytes_array, i); - android_exception_check_nonnull (bytes, bytes_array); + all_targets, i); + android_exception_check_nonnull (string, all_targets); /* Cons it onto the list of targets. */ - length1 = (*android_java_env)->GetArrayLength (android_java_env, - bytes); - data = (*android_java_env)->GetByteArrayElements (android_java_env, - bytes, NULL); - android_exception_check_nonnull_1 (data, bytes, bytes_array); + data = (*android_java_env)->GetStringUTFChars (android_java_env, + string, NULL); + android_exception_check_nonnull_1 ((void *) data, string, + all_targets); /* Decode the string. */ - tem = make_unibyte_string ((char *) data, length1); - tem = code_convert_string_norecord (tem, Qutf_8, false); + tem = build_unibyte_string ((char *) data); + tem = code_convert_string_norecord (tem, Qandroid_jni, false); targets = Fcons (tem, targets); /* Delete the retrieved data. */ - (*android_java_env)->ReleaseByteArrayElements (android_java_env, - bytes, data, - JNI_ABORT); - ANDROID_DELETE_LOCAL_REF (bytes); + (*android_java_env)->ReleaseStringUTFChars (android_java_env, + string, data); + ANDROID_DELETE_LOCAL_REF (string); } unblock_input (); - ANDROID_DELETE_LOCAL_REF (bytes_array); + ANDROID_DELETE_LOCAL_REF (all_targets); return Fnreverse (targets); fail: @@ -340,6 +340,62 @@ data type available from the clipboard. */) return Qnil; } + + +struct android_asset_file_descriptor +{ + jclass class; + jmethodID close; + jmethodID get_length; + jmethodID get_start_offset; + jmethodID get_file_descriptor; + jmethodID get_parcel_file_descriptor; + jmethodID get_fd; +}; + +/* Methods associated with the AssetFileDescriptor class. */ +static struct android_asset_file_descriptor asset_fd_class; + +/* Initialize virtual function IDs and class pointers in connection with + the AssetFileDescriptor class. */ + +static void +android_init_asset_file_descriptor (void) +{ + jclass old; + + asset_fd_class.class + = (*android_java_env)->FindClass (android_java_env, + "android/content/res/" + "AssetFileDescriptor"); + eassert (asset_fd_class.class); + + old = asset_fd_class.class; + asset_fd_class.class + = (jclass) (*android_java_env)->NewGlobalRef (android_java_env, + old); + ANDROID_DELETE_LOCAL_REF (old); + + if (!asset_fd_class.class) + emacs_abort (); + +#define FIND_METHOD(c_name, name, signature) \ + asset_fd_class.c_name \ + = (*android_java_env)->GetMethodID (android_java_env, \ + asset_fd_class.class, \ + name, signature); \ + eassert (asset_fd_class.c_name); + + FIND_METHOD (close, "close", "()V"); + FIND_METHOD (get_length, "getLength", "()J"); + FIND_METHOD (get_start_offset, "getStartOffset", "()J"); + FIND_METHOD (get_file_descriptor, "getFileDescriptor", + "()Ljava/io/FileDescriptor;"); + FIND_METHOD (get_parcel_file_descriptor, "getParcelFileDescriptor", + "()Landroid/os/ParcelFileDescriptor;"); +#undef FIND_METHOD +} + /* Free the memory inside PTR, a pointer to a char pointer. */ static void @@ -348,6 +404,125 @@ android_xfree_inside (void *ptr) xfree (*(char **) ptr); } +/* Close the referent of, then delete, the local reference to an asset + file descriptor referenced by AFD. */ + +static void +close_asset_fd (void *afd) +{ + jobject *afd_1; + + afd_1 = afd; + (*android_java_env)->CallVoidMethod (android_java_env, *afd_1, + asset_fd_class.close); + (*android_java_env)->ExceptionClear (android_java_env); + ANDROID_DELETE_LOCAL_REF (*afd_1); +} + +/* Return the offset, file descriptor and length of the data contained + in the asset file descriptor AFD, in *FD, *OFFSET, and *LENGTH. + Value is 0 upon success, 1 otherwise. */ + +static int +extract_fd_offsets (jobject afd, int *fd, jlong *offset, jlong *length) +{ + jobject java_fd; + void *handle; +#if __ANDROID_API__ <= 11 + static int (*jniGetFDFromFileDescriptor) (JNIEnv *, jobject); +#endif /* __ANDROID_API__ <= 11 */ + static int (*AFileDescriptor_getFd) (JNIEnv *, jobject); + jmethodID method; + + method = asset_fd_class.get_start_offset; + *offset = (*android_java_env)->CallLongMethod (android_java_env, + afd, method); + android_exception_check (); + method = asset_fd_class.get_length; + *length = (*android_java_env)->CallLongMethod (android_java_env, + afd, method); + android_exception_check (); + +#if __ANDROID_API__ <= 11 + if (android_get_current_api_level () <= 11) + { + /* Load libnativehelper and link to a private interface that is + the only means of retrieving the file descriptor from an asset + file descriptor on these systems. */ + + if (!jniGetFDFromFileDescriptor) + { + handle = dlopen ("libnativehelper.so", + RTLD_LAZY | RTLD_GLOBAL); + if (!handle) + goto failure; + jniGetFDFromFileDescriptor = dlsym (handle, + "jniGetFDFromFileDescriptor"); + if (!jniGetFDFromFileDescriptor) + goto failure; + } + + method = asset_fd_class.get_file_descriptor; + java_fd = (*android_java_env)->CallObjectMethod (android_java_env, + afd, method); + android_exception_check (); + *fd = (*jniGetFDFromFileDescriptor) (android_java_env, java_fd); + ANDROID_DELETE_LOCAL_REF (java_fd); + + if (*fd >= 0) + return 0; + } + else +#endif /* __ANDROID_API__ <= 11 */ +#if __ANDROID_API__ <= 30 + if (android_get_current_api_level () <= 30) + { + /* Convert this AssetFileDescriptor into a ParcelFileDescriptor, + whose getFd method will return its native file descriptor. */ + method = asset_fd_class.get_parcel_file_descriptor; + java_fd = (*android_java_env)->CallObjectMethod (android_java_env, + afd, method); + android_exception_check (); + + /* Initialize fd_class if not already complete. */ + android_init_fd_class (android_java_env); + *fd = (*android_java_env)->CallIntMethod (android_java_env, + java_fd, + fd_class.get_fd); + if (*fd >= 0) + return 0; + } + else +#endif /* __ANDROID_API__ <= 30 */ + { + /* Load libnativehelper (now a public interface) and link to + AFileDescriptor_getFd. */ + if (!AFileDescriptor_getFd) + { + handle = dlopen ("libnativehelper.so", + RTLD_LAZY | RTLD_GLOBAL); + if (!handle) + goto failure; + AFileDescriptor_getFd = dlsym (handle, "AFileDescriptor_getFd"); + if (!AFileDescriptor_getFd) + goto failure; + } + + method = asset_fd_class.get_file_descriptor; + java_fd = (*android_java_env)->CallObjectMethod (android_java_env, + afd, method); + android_exception_check (); + *fd = (*AFileDescriptor_getFd) (android_java_env, java_fd); + ANDROID_DELETE_LOCAL_REF (java_fd); + + if (*fd >= 0) + return 0; + } + + failure: + return 1; +} + DEFUN ("android-get-clipboard-data", Fandroid_get_clipboard_data, Sandroid_get_clipboard_data, 1, 1, 0, doc: /* Return the clipboard data of the given MIME TYPE. @@ -361,62 +536,46 @@ does not have any corresponding data. In that case, use `android-get-clipboard' instead. */) (Lisp_Object type) { - jlongArray array; - jbyteArray bytes; + jobject afd; + jstring mime_type; jmethodID method; int fd; ptrdiff_t rc; - jlong offset, length, *longs; + jlong offset, length; specpdl_ref ref; char *buffer, *start; if (!android_init_gui) error ("No Android display connection!"); - /* Encode the string as UTF-8. */ CHECK_STRING (type); - type = ENCODE_UTF_8 (type); - /* Then give it to the selection code. */ + /* Convert TYPE into a Java string. */ block_input (); - bytes = (*android_java_env)->NewByteArray (android_java_env, - SBYTES (type)); - (*android_java_env)->SetByteArrayRegion (android_java_env, bytes, - 0, SBYTES (type), - (jbyte *) SDATA (type)); - android_exception_check (); - + mime_type = android_build_string (type, NULL); method = clipboard_class.get_clipboard_data; - array = (*android_java_env)->CallObjectMethod (android_java_env, - clipboard, method, - bytes); - android_exception_check_1 (bytes); - ANDROID_DELETE_LOCAL_REF (bytes); + afd = (*android_java_env)->CallObjectMethod (android_java_env, + clipboard, method, + mime_type); + android_exception_check_1 (mime_type); + ANDROID_DELETE_LOCAL_REF (mime_type); - if (!array) + if (!afd) goto fail; - longs = (*android_java_env)->GetLongArrayElements (android_java_env, - array, NULL); - android_exception_check_nonnull (longs, array); - - /* longs[0] is the file descriptor. - longs[1] is an offset to apply to the file. - longs[2] is either -1, or the number of bytes to read from the - file. */ - fd = longs[0]; - offset = longs[1]; - length = longs[2]; + /* Extract the file descriptor from the AssetFileDescriptor + object. */ + ref = SPECPDL_INDEX (); + record_unwind_protect_ptr (close_asset_fd, &afd); - (*android_java_env)->ReleaseLongArrayElements (android_java_env, - array, longs, - JNI_ABORT); - ANDROID_DELETE_LOCAL_REF (array); + if (extract_fd_offsets (afd, &fd, &offset, &length)) + { + unblock_input (); + return unbind_to (ref, Qnil); + } unblock_input (); - /* Now begin reading from longs[0]. */ - ref = SPECPDL_INDEX (); - record_unwind_protect_int (close_file_unwind, fd); + /* Now begin reading from fd. */ if (length != -1) { @@ -1004,6 +1163,7 @@ init_androidselect (void) return; android_init_emacs_clipboard (); + android_init_asset_file_descriptor (); android_init_emacs_desktop_notification (); make_clipboard = clipboard_class.make_clipboard; diff --git a/src/androidterm.c b/src/androidterm.c index c920375fdbe..f4c071f4519 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -151,14 +151,8 @@ android_flash (struct frame *f) fd_set fds; block_input (); - - values.function = ANDROID_GC_XOR; - values.foreground = (FRAME_FOREGROUND_PIXEL (f) - ^ FRAME_BACKGROUND_PIXEL (f)); - - gc = android_create_gc ((ANDROID_GC_FUNCTION - | ANDROID_GC_FOREGROUND), - &values); + values.function = ANDROID_GC_INVERT; + gc = android_create_gc (ANDROID_GC_FUNCTION, &values); /* Get the height not including a menu bar widget. */ int height = FRAME_PIXEL_HEIGHT (f); @@ -1964,10 +1958,33 @@ android_parse_color (struct frame *f, const char *color_name, bool android_alloc_nearest_color (struct frame *f, Emacs_Color *color) { + unsigned int ntsc; + gamma_correct (f, color); - color->pixel = RGB_TO_ULONG (color->red / 256, - color->green / 256, - color->blue / 256); + + if (FRAME_DISPLAY_INFO (f)->n_planes == 1) + { + /* Black and white. I think this is the luminance formula applied + by the X server on generic monochrome framebuffers. */ + color->pixel = ((((30l * color->red + + 59l * color->green + + 11l * color->blue) >> 8) + >= (((1 << 8) -1) * 50)) + ? 0xffffff : 0); + } + else if (FRAME_DISPLAY_INFO (f)->n_planes <= 8) + { + /* 256 grays. */ + ntsc = min (255, ((color->red * 0.299 + + color->green * 0.587 + + color->blue * 0.114) + / 256)); + color->pixel = RGB_TO_ULONG (ntsc, ntsc, ntsc); + } + else + color->pixel = RGB_TO_ULONG (color->red / 256, + color->green / 256, + color->blue / 256); return true; } @@ -1980,8 +1997,8 @@ android_query_colors (struct frame *f, Emacs_Color *colors, int ncolors) for (i = 0; i < ncolors; ++i) { colors[i].red = RED_FROM_ULONG (colors[i].pixel) * 257; - colors[i].green = RED_FROM_ULONG (colors[i].pixel) * 257; - colors[i].blue = RED_FROM_ULONG (colors[i].pixel) * 257; + colors[i].green = GREEN_FROM_ULONG (colors[i].pixel) * 257; + colors[i].blue = BLUE_FROM_ULONG (colors[i].pixel) * 257; } } @@ -2630,7 +2647,7 @@ android_draw_fringe_bitmap (struct window *w, struct glyph_row *row, clipmask = ANDROID_NONE; background = face->background; cursor_pixel = f->output_data.android->cursor_pixel; - depth = FRAME_DISPLAY_INFO (f)->n_planes; + depth = FRAME_DISPLAY_INFO (f)->n_image_planes; /* Intersect the destination rectangle with that of the row. Setting a clip mask overrides the clip rectangles provided by @@ -3717,19 +3734,15 @@ static void android_get_scale_factor (int *scale_x, int *scale_y) { /* This is 96 everywhere else, but 160 on Android. */ - const int base_res = 160; - struct android_display_info *dpyinfo; + int base_res = 160; - dpyinfo = x_display_list; *scale_x = *scale_y = 1; + eassert (x_display_list); - if (dpyinfo) - { - if (dpyinfo->resx > base_res) - *scale_x = floor (dpyinfo->resx / base_res); - if (dpyinfo->resy > base_res) - *scale_y = floor (dpyinfo->resy / base_res); - } + if (x_display_list->resx > base_res) + *scale_x = floor (x_display_list->resx / base_res); + if (x_display_list->resy > base_res) + *scale_y = floor (x_display_list->resy / base_res); } static void @@ -4012,6 +4025,80 @@ android_draw_glyphless_glyph_string_foreground (struct glyph_string *s) s->char2b = NULL; } +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto F + at a vertical offset of OFFSET from the position of the glyph string + S, with each segment SEGMENT pixels in length. */ + +static void +android_draw_dash (struct frame *f, struct glyph_string *s, int width, + int segment, int offset, int thickness) +{ + struct android_gc *gc; + struct android_gc_values gcv; + int y_center; + + /* Configure the GC, the dash pattern and a suitable offset. */ + gc = s->gc; + + gcv.line_style = ANDROID_LINE_ON_OFF_DASH; + gcv.line_width = thickness; + android_change_gc (s->gc, (ANDROID_GC_LINE_STYLE + | ANDROID_GC_LINE_WIDTH), &gcv); + android_set_dashes (s->gc, s->x, &segment, 1); + + /* Offset the origin of the line by half the line width. */ + y_center = s->ybase + offset + thickness / 2; + android_draw_line (FRAME_ANDROID_WINDOW (f), gc, + s->x, y_center, s->x + width, y_center); + + /* Restore the initial line style. */ + gcv.line_style = ANDROID_LINE_SOLID; + gcv.line_width = 1; + android_change_gc (s->gc, (ANDROID_GC_LINE_STYLE + | ANDROID_GC_LINE_WIDTH), &gcv); +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, DECORATION_WIDTH in length, and + THICKNESS in height. */ + +static void +android_fill_underline (struct frame *f, struct glyph_string *s, + enum face_underline_type style, int position, + int decoration_width, int thickness) +{ + int segment; + + segment = thickness * 3; + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), + s->gc, s->x, s->ybase + position, + decoration_width, thickness); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + android_draw_dash (f, s, decoration_width, segment, position, + thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} + static void android_draw_glyph_string (struct glyph_string *s) { @@ -4135,7 +4222,7 @@ android_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (s->face->underline_defaulted_p) android_draw_underwave (s, decoration_width); @@ -4148,13 +4235,13 @@ android_draw_glyph_string (struct glyph_string *s) android_set_foreground (s->gc, xgcv.foreground); } } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -4231,19 +4318,35 @@ android_draw_glyph_string (struct glyph_string *s) thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; s->underline_position = position; - y = s->ybase + position; - if (s->face->underline_defaulted_p) - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, - s->x, y, decoration_width, thickness); - else - { - struct android_gc_values xgcv; - android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv); - android_set_foreground (s->gc, s->face->underline_color); - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, - s->x, y, decoration_width, thickness); - android_set_foreground (s->gc, xgcv.foreground); - } + + { + struct android_gc_values xgcv; + + if (!s->face->underline_defaulted_p) + { + android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv); + android_set_foreground (s->gc, s->face->underline_color); + } + + android_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + android_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); + } + + if (!s->face->underline_defaulted_p) + android_set_foreground (s->gc, xgcv.foreground); + } } } /* Draw overline. */ @@ -4822,7 +4925,7 @@ android_copy_java_string (JNIEnv *env, jstring string, size_t *length) } JNIEXPORT void JNICALL -NATIVE_NAME (beginBatchEdit) (JNIEnv *env, jobject object, jshort window) +NATIVE_NAME (beginBatchEdit) (JNIEnv *env, jobject object, jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -4843,7 +4946,7 @@ NATIVE_NAME (beginBatchEdit) (JNIEnv *env, jobject object, jshort window) } JNIEXPORT void JNICALL -NATIVE_NAME (endBatchEdit) (JNIEnv *env, jobject object, jshort window) +NATIVE_NAME (endBatchEdit) (JNIEnv *env, jobject object, jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -4864,7 +4967,7 @@ NATIVE_NAME (endBatchEdit) (JNIEnv *env, jobject object, jshort window) } JNIEXPORT void JNICALL -NATIVE_NAME (commitCompletion) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (commitCompletion) (JNIEnv *env, jobject object, jlong window, jstring completion_text, jint position) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -4898,7 +5001,7 @@ NATIVE_NAME (commitCompletion) (JNIEnv *env, jobject object, jshort window, } JNIEXPORT void JNICALL -NATIVE_NAME (commitText) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (commitText) (JNIEnv *env, jobject object, jlong window, jstring commit_text, jint position) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -4933,7 +5036,7 @@ NATIVE_NAME (commitText) (JNIEnv *env, jobject object, jshort window, JNIEXPORT void JNICALL NATIVE_NAME (deleteSurroundingText) (JNIEnv *env, jobject object, - jshort window, jint left_length, + jlong window, jint left_length, jint right_length) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -4956,7 +5059,7 @@ NATIVE_NAME (deleteSurroundingText) (JNIEnv *env, jobject object, JNIEXPORT void JNICALL NATIVE_NAME (finishComposingText) (JNIEnv *env, jobject object, - jshort window) + jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -4977,7 +5080,7 @@ NATIVE_NAME (finishComposingText) (JNIEnv *env, jobject object, } JNIEXPORT void JNICALL -NATIVE_NAME (replaceText) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (replaceText) (JNIEnv *env, jobject object, jlong window, jint start, jint end, jobject text, int new_cursor_position, jobject attribute) { @@ -5143,7 +5246,7 @@ android_text_to_string (JNIEnv *env, char *buffer, ptrdiff_t n, } JNIEXPORT jstring JNICALL -NATIVE_NAME (getTextAfterCursor) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (getTextAfterCursor) (JNIEnv *env, jobject object, jlong window, jint length, jint flags) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5187,7 +5290,7 @@ NATIVE_NAME (getTextAfterCursor) (JNIEnv *env, jobject object, jshort window, } JNIEXPORT jstring JNICALL -NATIVE_NAME (getTextBeforeCursor) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (getTextBeforeCursor) (JNIEnv *env, jobject object, jlong window, jint length, jint flags) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5231,7 +5334,7 @@ NATIVE_NAME (getTextBeforeCursor) (JNIEnv *env, jobject object, jshort window, } JNIEXPORT void JNICALL -NATIVE_NAME (setComposingText) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (setComposingText) (JNIEnv *env, jobject object, jlong window, jstring composing_text, jint new_cursor_position) { @@ -5266,7 +5369,7 @@ NATIVE_NAME (setComposingText) (JNIEnv *env, jobject object, jshort window, } JNIEXPORT void JNICALL -NATIVE_NAME (setComposingRegion) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (setComposingRegion) (JNIEnv *env, jobject object, jlong window, jint start, jint end) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5288,7 +5391,7 @@ NATIVE_NAME (setComposingRegion) (JNIEnv *env, jobject object, jshort window, } JNIEXPORT void JNICALL -NATIVE_NAME (setSelection) (JNIEnv *env, jobject object, jshort window, +NATIVE_NAME (setSelection) (JNIEnv *env, jobject object, jlong window, jint start, jint end) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5366,7 +5469,7 @@ android_get_selection (void *data) } JNIEXPORT jintArray JNICALL -NATIVE_NAME (getSelection) (JNIEnv *env, jobject object, jshort window) +NATIVE_NAME (getSelection) (JNIEnv *env, jobject object, jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5405,7 +5508,7 @@ NATIVE_NAME (getSelection) (JNIEnv *env, jobject object, jshort window) JNIEXPORT void JNICALL NATIVE_NAME (performEditorAction) (JNIEnv *env, jobject object, - jshort window, int action) + jlong window, int action) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5457,7 +5560,7 @@ NATIVE_NAME (performEditorAction) (JNIEnv *env, jobject object, JNIEXPORT void JNICALL NATIVE_NAME (performContextMenuAction) (JNIEnv *env, jobject object, - jshort window, int action) + jlong window, int action) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5662,7 +5765,7 @@ android_build_extracted_text (jstring text, ptrdiff_t start, JNIEXPORT jobject JNICALL NATIVE_NAME (getExtractedText) (JNIEnv *env, jobject ignored_object, - jshort window, jobject request, + jlong window, jobject request, jint flags) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5774,7 +5877,7 @@ NATIVE_NAME (getExtractedText) (JNIEnv *env, jobject ignored_object, JNIEXPORT jstring JNICALL NATIVE_NAME (getSelectedText) (JNIEnv *env, jobject object, - jshort window) + jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5804,7 +5907,7 @@ NATIVE_NAME (getSelectedText) (JNIEnv *env, jobject object, JNIEXPORT void JNICALL NATIVE_NAME (requestSelectionUpdate) (JNIEnv *env, jobject object, - jshort window) + jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5826,7 +5929,7 @@ NATIVE_NAME (requestSelectionUpdate) (JNIEnv *env, jobject object, JNIEXPORT void JNICALL NATIVE_NAME (requestCursorUpdates) (JNIEnv *env, jobject object, - jshort window, jint mode) + jlong window, jint mode) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5855,7 +5958,7 @@ NATIVE_NAME (requestCursorUpdates) (JNIEnv *env, jobject object, JNIEXPORT void JNICALL NATIVE_NAME (clearInputFlags) (JNIEnv *env, jobject object, - jshort window) + jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -5970,7 +6073,7 @@ android_get_surrounding_text (void *data) Value is the object upon success, else NULL. */ static jobject -android_get_surrounding_text_internal (JNIEnv *env, jshort window, +android_get_surrounding_text_internal (JNIEnv *env, jlong window, jint before_length, jint after_length, ptrdiff_t *conversion_start, @@ -6063,7 +6166,7 @@ android_get_surrounding_text_internal (JNIEnv *env, jshort window, JNIEXPORT jobject JNICALL NATIVE_NAME (getSurroundingText) (JNIEnv *env, jobject object, - jshort window, jint before_length, + jlong window, jint before_length, jint after_length, jint flags) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -6073,7 +6176,7 @@ NATIVE_NAME (getSurroundingText) (JNIEnv *env, jobject object, } JNIEXPORT jobject JNICALL -NATIVE_NAME (takeSnapshot) (JNIEnv *env, jobject object, jshort window) +NATIVE_NAME (takeSnapshot) (JNIEnv *env, jobject object, jlong window) { JNI_STACK_ALIGNMENT_PROLOGUE; @@ -6156,14 +6259,24 @@ android_update_selection (struct frame *f, struct window *w) jobject extracted; jstring string; bool mark_active; + ptrdiff_t field_start, field_end; + + /* Offset these values by the start offset of the field. */ + get_conversion_field (f, &field_start, &field_end); if (MARKERP (f->conversion.compose_region_start)) { eassert (MARKERP (f->conversion.compose_region_end)); /* Indexing in android starts from 0 instead of 1. */ - start = marker_position (f->conversion.compose_region_start) - 1; - end = marker_position (f->conversion.compose_region_end) - 1; + start = marker_position (f->conversion.compose_region_start); + end = marker_position (f->conversion.compose_region_end); + + /* Offset and detect underflow. */ + start = max (start, field_start) - field_start - 1; + end = min (end, field_end) - field_start - 1; + if (end < 0 || start < 0) + end = start = -1; } else start = -1, end = -1; @@ -6179,24 +6292,27 @@ android_update_selection (struct frame *f, struct window *w) /* Figure out where the point and mark are. If the mark is not active, then point is set to equal mark. */ b = XBUFFER (w->contents); - point = min (w->ephemeral_last_point, + point = min (min (max (w->ephemeral_last_point, + field_start), + field_end) - field_start, TYPE_MAXIMUM (jint)); mark = ((!NILP (BVAR (b, mark_active)) && w->last_mark != -1) - ? min (w->last_mark, TYPE_MAXIMUM (jint)) + ? min (min (max (w->last_mark, field_start), + field_end) - field_start, + TYPE_MAXIMUM (jint)) : point); - /* Send the update. Android doesn't employ a concept of ``point'' - and ``mark''; instead, it only has a selection, where the start - of the selection is less than or equal to the end, and the region - is ``active'' when those two values differ. Also, convert the - indices from 1-based Emacs indices to 0-based Android ones. */ - android_update_ic (FRAME_ANDROID_WINDOW (f), min (point, mark) - 1, - max (point, mark) - 1, start, end); + /* Send the update. Android doesn't employ a concept of "point" and + "mark"; instead, it only has a selection, where the start of the + selection is less than or equal to the end, and the region is + "active" when those two values differ. The indices will have been + converted from 1-based Emacs indices to 0-based Android ones. */ + android_update_ic (FRAME_ANDROID_WINDOW (f), min (point, mark), + max (point, mark), start, end); /* Update the extracted text as well, if the input method has asked - for updates. 1 is - InputConnection.GET_EXTRACTED_TEXT_MONITOR. */ + for updates. 1 is InputConnection.GET_EXTRACTED_TEXT_MONITOR. */ if (FRAME_ANDROID_OUTPUT (f)->extracted_text_flags & 1) { @@ -6504,8 +6620,8 @@ android_term_init (void) terminal = android_create_terminal (dpyinfo); terminal->kboard = allocate_kboard (Qandroid); terminal->kboard->reference_count++; - dpyinfo->n_planes = 24; + dpyinfo->n_image_planes = 24; /* This function should only be called once at startup. */ eassert (!x_display_list); @@ -6680,6 +6796,22 @@ so it is important to limit the wait. If set to a non-float value, there will be no wait at all. */); Vandroid_wait_for_event_timeout = make_float (0.1); + DEFVAR_INT ("android-quit-keycode", android_quit_keycode, + doc: /* Keycode that signals quit when typed twice in rapid succession. + +This is the key code of a key whose repeated activation should prompt +Emacs to quit, enabling quitting on systems where a keyboard capable of +typing C-g is unavailable, when set to a key that does exist on the +device. Its value must be a keycode defined by the operating system, +and defaults to 25 (KEYCODE_VOLUME_DOWN), though one of the following +values might be desired on those devices where this default is also +unavailable, or if another key must otherwise serve this function +instead: + + - 4 (KEYCODE_BACK) + - 24 (KEYCODE_VOLUME_UP) */); + android_quit_keycode = 25; + DEFVAR_BOOL ("x-use-underline-position-properties", x_use_underline_position_properties, doc: /* SKIP: real doc in xterm.c. */); @@ -6702,6 +6834,17 @@ Emacs is running on. */); doc: /* Name of the developer of the running version of Android. */); Vandroid_build_manufacturer = Qnil; + DEFVAR_INT ("android-display-planes", android_display_planes, + doc: /* Depth and visual class of the display. +This variable controls the visual class and depth of the display, which +cannot be detected on Android. The default value of 24, and values from +there to 8 represent a TrueColor display providing 24 planes, values +between 8 and 1 StaticGray displays providing that many planes, and 1 or +lower monochrome displays with a single plane. Modifications to this +variable must be completed before the window system is initialized, in, +for instance, `early-init.el', or they will be of no effect. */); + android_display_planes = 24; + DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, doc: /* SKIP: real doc in xterm.c. */); Vx_ctrl_keysym = Qnil; diff --git a/src/androidterm.h b/src/androidterm.h index fd4cc99f641..24eb2c30f12 100644 --- a/src/androidterm.h +++ b/src/androidterm.h @@ -77,8 +77,9 @@ struct android_display_info /* Mouse highlight information. */ Mouse_HLInfo mouse_highlight; - /* Number of planes on this screen. Always 24. */ - int n_planes; + /* Number of planes on this screen, and the same for the purposes of + image processing. */ + int n_planes, n_image_planes; /* Mask of things causing the mouse to be grabbed. */ int grabbed; diff --git a/src/androidvfs.c b/src/androidvfs.c index a9035ae53c6..004abd62518 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -290,17 +290,6 @@ struct emacs_directory_entry_class jfieldID d_name; }; -/* Structure describing the android.os.ParcelFileDescriptor class used - to wrap file descriptors sent over IPC. */ - -struct android_parcel_file_descriptor_class -{ - jclass class; - jmethodID close; - jmethodID get_fd; - jmethodID detach_fd; -}; - /* The java.lang.String class. */ jclass java_string_class; @@ -313,7 +302,7 @@ static struct emacs_directory_entry_class entry_class; /* Fields and methods associated with the ParcelFileDescriptor class. */ -static struct android_parcel_file_descriptor_class fd_class; +struct android_parcel_file_descriptor_class fd_class; /* Global references to several exception classes. */ static jclass file_not_found_exception, security_exception; @@ -380,13 +369,18 @@ android_init_entry_class (JNIEnv *env) } -/* Initialize `fd_class' using the given JNI environment ENV. Calling - this function is not necessary on Android 4.4 and earlier. */ +/* Initialize `fd_class' using the given JNI environment ENV. Called on + API 12 (Android 3.1) and later by androidselect.c and on 5.0 and + later in this file. */ -static void +void android_init_fd_class (JNIEnv *env) { jclass old; + static bool fd_class_initialized; + + if (fd_class_initialized) + return; fd_class.class = (*env)->FindClass (env, "android/os/ParcelFileDescriptor"); @@ -409,6 +403,8 @@ android_init_fd_class (JNIEnv *env) FIND_METHOD (get_fd, "getFd", "()I"); FIND_METHOD (detach_fd, "detachFd", "()I"); #undef FIND_METHOD + + fd_class_initialized = true; } @@ -2817,7 +2813,7 @@ android_content_opendir (struct android_vnode *vnode) /* Android 4.3 and earlier don't support /content/by-authority. */ if (api < 19) - dir->next_name++; + dir->next_name += 2; /* Link this stream onto the list of all content directory streams. */ @@ -3027,6 +3023,104 @@ android_check_content_access (const char *uri, int mode) +/* Functions shared by authority and SAF nodes. */ + +/* Check for JNI exceptions, clear them, and set errno accordingly. + Also, free each of the N local references given as arguments if an + exception takes place. + + Value is 1 if an exception has taken place, 0 otherwise. + + If the exception thrown derives from FileNotFoundException, set + errno to ENOENT. + + If the exception thrown derives from SecurityException, set errno + to EACCES. + + If the exception thrown derives from OperationCanceledException, + set errno to EINTR. + + If the exception thrown derives from UnsupportedOperationException, + set errno to ENOSYS. + + If the exception thrown derives from OutOfMemoryException, call + `memory_full'. + + If the exception thrown is anything else, set errno to EIO. */ + +static int +android_saf_exception_check (int n, ...) +{ + jthrowable exception; + JNIEnv *env; + va_list ap; + int new_errno; + + env = android_java_env; + va_start (ap, n); + + /* First, check for an exception. */ + + if (!(*env)->ExceptionCheck (env)) + { + /* No exception has taken place. Return 0. */ + va_end (ap); + return 0; + } + + /* Print the exception. */ + (*env)->ExceptionDescribe (env); + + exception = (*env)->ExceptionOccurred (env); + + if (!exception) + /* JNI couldn't return a local reference to the exception. */ + memory_full (0); + + /* Clear the exception, making it safe to subsequently call other + JNI functions. */ + (*env)->ExceptionClear (env); + + /* Delete each of the N arguments. */ + + while (n > 0) + { + ANDROID_DELETE_LOCAL_REF (va_arg (ap, jobject)); + n--; + } + + /* Now set errno or signal memory_full as required. */ + + if ((*env)->IsInstanceOf (env, (jobject) exception, + file_not_found_exception)) + new_errno = ENOENT; + else if ((*env)->IsInstanceOf (env, (jobject) exception, + security_exception)) + new_errno = EACCES; + else if ((*env)->IsInstanceOf (env, (jobject) exception, + operation_canceled_exception)) + new_errno = EINTR; + else if ((*env)->IsInstanceOf (env, (jobject) exception, + unsupported_operation_exception)) + new_errno = ENOSYS; + else if ((*env)->IsInstanceOf (env, (jobject) exception, + out_of_memory_error)) + { + ANDROID_DELETE_LOCAL_REF ((jobject) exception); + memory_full (0); + } + else + new_errno = EIO; + + /* expression is still a local reference! */ + ANDROID_DELETE_LOCAL_REF ((jobject) exception); + errno = new_errno; + va_end (ap); + return 1; +} + + + /* Content authority-based vnode implementation. /content/by-authority is a simple vnode implementation that converts @@ -3130,8 +3224,10 @@ android_authority_name (struct android_vnode *vnode, char *name, return NULL; } - /* NAME must be a valid JNI string, so that it can be encoded - properly. */ + /* If the URI is not a valid JNI string, return immediately. This + should not be possible, since /content file names are encoded + into JNI strings at the naming stage; the check is performed + only out of an abundance of caution. */ if (android_verify_jni_string (name)) goto no_entry; @@ -3169,7 +3265,6 @@ android_authority_open (struct android_vnode *vnode, int flags, AAsset **asset) { struct android_authority_vnode *vp; - size_t length; jobject string; int fd; JNIEnv *env; @@ -3189,22 +3284,11 @@ android_authority_open (struct android_vnode *vnode, int flags, feasible. */ env = android_java_env; - /* Allocate a buffer to hold the file name. */ - length = strlen (vp->uri); - string = (*env)->NewByteArray (env, length); - if (!string) - { - (*env)->ExceptionClear (env); - errno = ENOMEM; - return -1; - } - - /* Copy the URI into this byte array. */ - (*env)->SetByteArrayRegion (env, string, 0, length, - (jbyte *) vp->uri); + /* Allocate a JNI string to hold VP->uri. */ + string = (*env)->NewStringUTF (env, vp->uri); + android_exception_check (); /* Try to open the file descriptor. */ - fd = (*env)->CallNonvirtualIntMethod (env, emacs_service, service_class.class, service_class.open_content_uri, @@ -3215,13 +3299,9 @@ android_authority_open (struct android_vnode *vnode, int flags, (jboolean) !(mode & O_WRONLY), (jboolean) ((mode & O_TRUNC) != 0)); - if ((*env)->ExceptionCheck (env)) - { - (*env)->ExceptionClear (env); - errno = ENOMEM; - ANDROID_DELETE_LOCAL_REF (string); - return -1; - } + if (android_saf_exception_check (1, string)) + return -1; + ANDROID_DELETE_LOCAL_REF (string); /* If fd is -1, just assume that the file does not exist, and return -1 with errno set to ENOENT. */ @@ -3229,18 +3309,12 @@ android_authority_open (struct android_vnode *vnode, int flags, if (fd == -1) { errno = ENOENT; - goto skip; + return -1; } if (mode & O_CLOEXEC) android_close_on_exec (fd); - skip: - ANDROID_DELETE_LOCAL_REF (string); - - if (fd == -1) - return -1; - *fd_return = fd; return 0; } @@ -3959,7 +4033,7 @@ android_saf_root_opendir (struct android_vnode *vnode) struct android_saf_root_vnode *vp; jobjectArray array; jmethodID method; - jbyteArray authority; + jstring authority; struct android_saf_root_vdir *dir; size_t length; @@ -3969,15 +4043,10 @@ android_saf_root_opendir (struct android_vnode *vnode) { /* Build a string containing the authority. */ length = strlen (vp->authority); - authority = (*android_java_env)->NewByteArray (android_java_env, - length); + authority = (*android_java_env)->NewStringUTF (android_java_env, + vp->authority); android_exception_check (); - /* Copy the authority name to that byte array. */ - (*android_java_env)->SetByteArrayRegion (android_java_env, - authority, 0, length, - (jbyte *) vp->authority); - /* Acquire a list of every tree provided by this authority. */ method = service_class.get_document_trees; @@ -4109,100 +4178,6 @@ android_saf_root_get_directory (int dirfd) thread. */ static bool inside_saf_critical_section; -/* Check for JNI exceptions, clear them, and set errno accordingly. - Also, free each of the N local references given as arguments if an - exception takes place. - - Value is 1 if an exception has taken place, 0 otherwise. - - If the exception thrown derives from FileNotFoundException, set - errno to ENOENT. - - If the exception thrown derives from SecurityException, set errno - to EACCES. - - If the exception thrown derives from OperationCanceledException, - set errno to EINTR. - - If the exception thrown derives from UnsupportedOperationException, - set errno to ENOSYS. - - If the exception thrown derives from OutOfMemoryException, call - `memory_full'. - - If the exception thrown is anything else, set errno to EIO. */ - -static int -android_saf_exception_check (int n, ...) -{ - jthrowable exception; - JNIEnv *env; - va_list ap; - int new_errno; - - env = android_java_env; - va_start (ap, n); - - /* First, check for an exception. */ - - if (!(*env)->ExceptionCheck (env)) - { - /* No exception has taken place. Return 0. */ - va_end (ap); - return 0; - } - - /* Print the exception. */ - (*env)->ExceptionDescribe (env); - - exception = (*env)->ExceptionOccurred (env); - - if (!exception) - /* JNI couldn't return a local reference to the exception. */ - memory_full (0); - - /* Clear the exception, making it safe to subsequently call other - JNI functions. */ - (*env)->ExceptionClear (env); - - /* Delete each of the N arguments. */ - - while (n > 0) - { - ANDROID_DELETE_LOCAL_REF (va_arg (ap, jobject)); - n--; - } - - /* Now set errno or signal memory_full as required. */ - - if ((*env)->IsInstanceOf (env, (jobject) exception, - file_not_found_exception)) - new_errno = ENOENT; - else if ((*env)->IsInstanceOf (env, (jobject) exception, - security_exception)) - new_errno = EACCES; - else if ((*env)->IsInstanceOf (env, (jobject) exception, - operation_canceled_exception)) - new_errno = EINTR; - else if ((*env)->IsInstanceOf (env, (jobject) exception, - unsupported_operation_exception)) - new_errno = ENOSYS; - else if ((*env)->IsInstanceOf (env, (jobject) exception, - out_of_memory_error)) - { - ANDROID_DELETE_LOCAL_REF ((jobject) exception); - memory_full (0); - } - else - new_errno = EIO; - - /* expression is still a local reference! */ - ANDROID_DELETE_LOCAL_REF ((jobject) exception); - errno = new_errno; - va_end (ap); - return 1; -} - /* Return file status for the document designated by ID_NAME within the document tree identified by URI_NAME. @@ -4997,7 +4972,7 @@ android_saf_tree_name (struct android_vnode *vnode, char *name, root.vnode.type = ANDROID_VNODE_SAF_ROOT; root.vnode.flags = 0; - /* Find the authority from the URI. */ + /* Derive the authority from the URI. */ fill = (char *) vp->tree_uri; @@ -5647,7 +5622,7 @@ android_saf_tree_opendir (struct android_vnode *vnode) dir->vdir.closedir = android_saf_tree_closedir; dir->vdir.dirfd = android_saf_tree_dirfd; - /* Find the authority from the URI. */ + /* Derive the authority from the URI. */ fill = (char *) vp->tree_uri; @@ -6525,11 +6500,33 @@ NATIVE_NAME (ftruncate) (JNIEnv *env, jobject object, jint fd) /* Root vnode. This vnode represents the root inode, and is a regular - Unix vnode with modifications to `name' that make it return asset - vnodes. */ + Unix vnode with modifications to `name' so that it returns asset and + content vnodes, and to `opendir', so that asset and content vnodes + are read from the root directory, whether or not Emacs holds rights + to access the underlying filesystem. */ + +struct android_root_vdir +{ + /* The directory function table. */ + struct android_vdir vdir; + + /* The directory stream, or NULL if it could not be opened. */ + DIR *directory; + + /* Index of the next directory to return in `special_vnodes'. */ + int index; +}; + +/* File descriptor for instances of the foregoing structure when the + true root is unavailable. */ +static int root_fd = -1; + +/* Number of open instances referencing this file descriptor. */ +static ptrdiff_t root_fd_references; static struct android_vnode *android_root_name (struct android_vnode *, char *, size_t); +static struct android_vdir *android_root_opendir (struct android_vnode *); /* Vector of VFS operations associated with Unix root filesystem VFS nodes. */ @@ -6548,7 +6545,7 @@ static struct android_vops root_vfs_ops = android_unix_mkdir, android_unix_chmod, android_unix_readlink, - android_unix_opendir, + android_root_opendir, }; /* Array of special named vnodes. */ @@ -6564,10 +6561,11 @@ static struct android_special_vnode special_vnodes[] = to CODING, and return a Lisp string with the data so produced. Calling this function creates an implicit assumption that - file-name-coding-system is compatible with utf-8-emacs, which is not - unacceptable as users with cause to modify file-name-coding-system - should be aware and prepared for consequences towards files stored on - different filesystems, including virtual ones. */ + `file-name-coding-system' is compatible with `utf-8-emacs', which is + not unacceptable as users with cause to modify + file-name-coding-system should be aware and prepared for adverse + consequences affecting files stored on different filesystems, + including virtual ones. */ static Lisp_Object android_vfs_convert_name (const char *name, Lisp_Object coding) @@ -6676,6 +6674,92 @@ android_root_name (struct android_vnode *vnode, char *name, return android_unix_name (vnode, name, length); } +static struct dirent * +android_root_readdir (struct android_vdir *vdir) +{ + struct android_root_vdir *dir; + static struct dirent dirent, *p; + + dir = (struct android_root_vdir *) vdir; + p = dir->directory ? readdir (dir->directory) : NULL; + + if (p || dir->index >= ARRAYELTS (special_vnodes)) + return p; + + dirent.d_ino = 0; + dirent.d_off = 0; + dirent.d_reclen = sizeof dirent; + dirent.d_type = DT_DIR; + + /* No element in special_vnode must overflow dirent.d_name. */ + strcpy ((char *) &dirent.d_name, + special_vnodes[dir->index++].name); + return &dirent; +} + +static void +android_root_closedir (struct android_vdir *vdir) +{ + struct android_root_vdir *dir; + + dir = (struct android_root_vdir *) vdir; + + if (dir->directory) + closedir (dir->directory); + + if (root_fd_references--) + ; + else + { + /* Close root_fd, for which no references remain. */ + close (root_fd); + root_fd = -1; + } + + xfree (vdir); +} + +static int +android_root_dirfd (struct android_vdir *vdir) +{ + eassert (root_fd != -1); + return root_fd; +} + +static struct android_vdir * +android_root_opendir (struct android_vnode *vnode) +{ + struct android_unix_vnode *vp; + struct android_root_vdir *dir; + DIR *directory; + + /* Try to opendir the vnode. */ + vp = (struct android_unix_vnode *) vnode; + + directory = opendir (vp->name); + + /* Proceed with the remaining code if directory is nil, in which event + directory functions will simply forgo listing files inside the real + root directory. */ + + dir = xmalloc (sizeof *dir); + dir->vdir.readdir = android_root_readdir; + dir->vdir.closedir = android_root_closedir; + dir->vdir.dirfd = android_root_dirfd; + dir->directory = directory; + dir->index = 0; + + /* Allocate a temporary file descriptor for this ersatz root. This is + required regardless of the value of DIRECTORY, as android_fstatat + and co. will not defer to the VFS layer if a directory file + descriptor is not known to be special. */ + if (root_fd < 0) + root_fd = open ("/dev/null", O_RDONLY | O_CLOEXEC); + root_fd_references++; + + return &dir->vdir; +} + /* File system lookup. */ @@ -6795,15 +6879,9 @@ android_vfs_init (JNIEnv *env, jobject manager) eassert (java_string_class); (*env)->DeleteLocalRef (env, old); - /* And initialize those used on Android 5.0 and later. */ - - if (android_get_current_api_level () < 21) + if (android_get_current_api_level () < 19) return; - android_init_cursor_class (env); - android_init_entry_class (env); - android_init_fd_class (env); - /* Initialize each of the exception classes used by `android_saf_exception_check'. */ @@ -6832,6 +6910,15 @@ android_vfs_init (JNIEnv *env, jobject manager) (*env)->DeleteLocalRef (env, old); eassert (out_of_memory_error); + /* And initialize those used on Android 5.0 and later. */ + + if (android_get_current_api_level () < 21) + return; + + android_init_cursor_class (env); + android_init_entry_class (env); + android_init_fd_class (env); + /* Initialize the semaphore used to wait for SAF operations to complete. */ @@ -7223,6 +7310,14 @@ android_fstatat_1 (int dirfd, const char *filename, return 0; } + /* /foo... */ + + if (root_fd >= 0 && dirfd == root_fd) + { + snprintf (buffer, size, "/%s", filename); + return 0; + } + return 1; } @@ -7700,8 +7795,65 @@ android_closedir (struct android_vdir *dirp) +DEFUN ("android-relinquish-directory-access", + Fandroid_relinquish_directory_access, + Sandroid_relinquish_directory_access, 1, 1, + "DDirectory: ", + doc: /* Relinquish access to the provided directory. +DIRECTORY must be the toplevel directory of an open SAF volume (i.e., a +file under /content/storage), or one of its inferiors. Once the command +completes, the SAF directory holding this directory will vanish, but no +files will be removed. */) + (Lisp_Object file) +{ + struct android_vnode *vp; + struct android_saf_tree_vnode *saf_tree; + jstring string; + jmethodID method; + + if (android_get_current_api_level () < 21) + error ("Emacs can only access or relinquish application storage on" + " Android 5.0 and later"); + + if (!android_init_gui) + return Qnil; + + file = ENCODE_FILE (Fexpand_file_name (file, Qnil)); + + if (!NILP (call1 (Qfile_remote_p, file))) + signal_error ("Cannot relinquish access to remote file", file); + + vp = android_name_file (SSDATA (file)); + + if (!vp) + report_file_error ("Relinquishing directory", file); + + if (vp->type != ANDROID_VNODE_SAF_TREE) + { + (*vp->ops->close) (vp); + signal_error ("Access to this directory cannot be relinquished", + file); + } + + saf_tree = (struct android_saf_tree_vnode *) vp; + string = android_build_jstring (saf_tree->tree_uri); + method = service_class.relinquish_uri_rights; + (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, + emacs_service, + service_class.class, + method, string); + (*vp->ops->close) (vp); + android_exception_check_1 (string); + ANDROID_DELETE_LOCAL_REF (string); + return Qnil; +} + + + void syms_of_androidvfs (void) { DEFSYM (Qandroid_jni, "android-jni"); + + defsubr (&Sandroid_relinquish_directory_access); } diff --git a/src/buffer.c b/src/buffer.c index 291c7d3f911..8f983692124 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -931,8 +931,8 @@ Interactively, CLONE and INHIBIT-BUFFER-HOOKS are nil. */) bset_local_minor_modes (b, Qnil); bset_auto_save_file_name (b, Qnil); set_buffer_internal_1 (b); - Fset (intern ("buffer-save-without-query"), Qnil); - Fset (intern ("buffer-file-number"), Qnil); + Fset (Qbuffer_save_without_query, Qnil); + Fset (Qbuffer_file_number, Qnil); if (!NILP (Flocal_variable_p (Qbuffer_stale_function, base_buffer))) Fkill_local_variable (Qbuffer_stale_function); /* Cloned buffers need extra setup, to do things such as deep @@ -1477,7 +1477,7 @@ No argument or nil as argument means use current buffer as BUFFER. */) } tem = buffer_local_variables_1 (buf, PER_BUFFER_VAR_OFFSET (undo_list), - intern ("buffer-undo-list")); + Qbuffer_undo_list); if (!NILP (tem)) result = Fcons (tem, result); @@ -1704,11 +1704,11 @@ This does not change the name of the visited file (if any). */) Fsetcar (Frassq (buf, Vbuffer_alist), newname); if (NILP (BVAR (current_buffer, filename)) && !NILP (BVAR (current_buffer, auto_save_file_name))) - call0 (intern ("rename-auto-save-file")); + call0 (Qrename_auto_save_file); run_buffer_list_update_hook (current_buffer); - call2 (intern ("uniquify--rename-buffer-advice"), + call2 (Quniquify__rename_buffer_advice, requestedname, unique); /* Refetch since that last call may have done GC. */ @@ -1956,7 +1956,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) { tem = do_yes_or_no_p (build_string ("Delete auto-save file? ")); if (!NILP (tem)) - call0 (intern ("delete-auto-save-file-if-necessary")); + call0 (Qdelete_auto_save_file_if_necessary); } /* If the hooks have killed the buffer, exit now. */ @@ -2251,7 +2251,7 @@ the current buffer's major mode. */) error ("Attempt to set major mode for a dead buffer"); if (strcmp (SSDATA (BVAR (XBUFFER (buffer), name)), "*scratch*") == 0) - function = find_symbol_value (intern ("initial-major-mode")); + function = find_symbol_value (Qinitial_major_mode); else { function = BVAR (&buffer_defaults, major_mode); @@ -2936,7 +2936,7 @@ current buffer is cleared. */) /* Represent all the above changes by a special undo entry. */ bset_undo_list (current_buffer, Fcons (list3 (Qapply, - intern ("set-buffer-multibyte"), + Qset_buffer_multibyte, NILP (flag) ? Qt : Qnil), old_undo)); } @@ -6112,4 +6112,13 @@ There is no reason to change that value except for debugging purposes. */); DEFSYM (Qbuffer_stale_function, "buffer-stale-function"); Fput (intern_c_string ("erase-buffer"), Qdisabled, Qt); + + DEFSYM (Qbuffer_save_without_query, "buffer-save-without-query"); + DEFSYM (Qbuffer_file_number, "buffer-file-number"); + DEFSYM (Qbuffer_undo_list, "buffer-undo-list"); + DEFSYM (Qrename_auto_save_file, "rename-auto-save-file"); + DEFSYM (Quniquify__rename_buffer_advice, "uniquify--rename-buffer-advice"); + DEFSYM (Qdelete_auto_save_file_if_necessary, "delete-auto-save-file-if-necessary"); + DEFSYM (Qinitial_major_mode, "initial-major-mode"); + DEFSYM (Qset_buffer_multibyte, "set-buffer-multibyte"); } diff --git a/src/bytecode.c b/src/bytecode.c index 8d7240b9966..03443ed54ab 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -479,7 +479,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, Lisp_Object *top = NULL; unsigned char const *pc = NULL; - Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + Lisp_Object bytestr = AREF (fun, CLOSURE_CODE); setup_frame: ; eassert (!STRING_MULTIBYTE (bytestr)); @@ -489,8 +489,8 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, when returning, to detect unwind imbalances. This would require adding a field to the frame header. */ - Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); - Lisp_Object maxdepth = AREF (fun, COMPILED_STACK_DEPTH); + Lisp_Object vector = AREF (fun, CLOSURE_CONSTANTS); + Lisp_Object maxdepth = AREF (fun, CLOSURE_STACK_DEPTH); ptrdiff_t const_length = ASIZE (vector); ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; @@ -625,8 +625,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, varref: { Lisp_Object v1 = vectorp[op], v2; - if (!BARE_SYMBOL_P (v1) - || XBARE_SYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL + if (XBARE_SYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL || (v2 = XBARE_SYMBOL (v1)->u.s.val.value, BASE_EQ (v2, Qunbound))) v2 = Fsymbol_value (v1); @@ -700,8 +699,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, Lisp_Object val = POP; /* Inline the most common case. */ - if (BARE_SYMBOL_P (sym) - && !BASE_EQ (val, Qunbound) + if (!BASE_EQ (val, Qunbound) && XBARE_SYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL && !XBARE_SYMBOL (sym)->u.s.trapped_write) SET_SYMBOL_VAL (XBARE_SYMBOL (sym), val); @@ -794,14 +792,14 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, /* Calls to symbols-with-pos don't need to be on the fast path. */ if (BARE_SYMBOL_P (call_fun)) call_fun = XBARE_SYMBOL (call_fun)->u.s.function; - if (COMPILEDP (call_fun)) + if (CLOSUREP (call_fun)) { - Lisp_Object template = AREF (call_fun, COMPILED_ARGLIST); + Lisp_Object template = AREF (call_fun, CLOSURE_ARGLIST); if (FIXNUMP (template)) { /* Fast path for lexbound functions. */ fun = call_fun; - bytestr = AREF (call_fun, COMPILED_BYTECODE), + bytestr = AREF (call_fun, CLOSURE_CODE), args_template = XFIXNUM (template); nargs = call_nargs; args = call_args; @@ -899,8 +897,8 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, bc->fp = fp; Lisp_Object fun = fp->fun; - Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); - Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + Lisp_Object bytestr = AREF (fun, CLOSURE_CODE); + Lisp_Object vector = AREF (fun, CLOSURE_CONSTANTS); bytestr_data = SDATA (bytestr); vectorp = XVECTOR (vector)->contents; if (BYTE_CODE_SAFE) @@ -976,8 +974,8 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, struct bc_frame *fp = bc->fp; Lisp_Object fun = fp->fun; - Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); - Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + Lisp_Object bytestr = AREF (fun, CLOSURE_CODE); + Lisp_Object vector = AREF (fun, CLOSURE_CONSTANTS); bytestr_data = SDATA (bytestr); vectorp = XVECTOR (vector)->contents; if (BYTE_CODE_SAFE) diff --git a/src/callint.c b/src/callint.c index b31faba8704..1af9666e5a4 100644 --- a/src/callint.c +++ b/src/callint.c @@ -228,7 +228,7 @@ static Lisp_Object read_file_name (Lisp_Object default_filename, Lisp_Object mustmatch, Lisp_Object initial, Lisp_Object predicate) { - return CALLN (Ffuncall, intern ("read-file-name"), + return CALLN (Ffuncall, Qread_file_name, callint_message, Qnil, default_filename, mustmatch, initial, predicate); } @@ -319,10 +319,10 @@ invoke it (via an `interactive' spec that contains, for instance, an { Lisp_Object funval = Findirect_function (function, Qt); uintmax_t events = num_input_events; + Lisp_Object env = CLOSUREP (funval) && CONSP (AREF (funval, CLOSURE_CODE)) + ? AREF (funval, CLOSURE_CONSTANTS) : Qnil; /* Compute the arg values using the user's expression. */ - specs = Feval (specs, - CONSP (funval) && EQ (Qclosure, XCAR (funval)) - ? CAR_SAFE (XCDR (funval)) : Qnil); + specs = Feval (specs, env); if (events != num_input_events || !NILP (record_flag)) { /* We should record this command on the command history. @@ -330,7 +330,7 @@ invoke it (via an `interactive' spec that contains, for instance, an and turn them into things we can eval. */ Lisp_Object values = quotify_args (Fcopy_sequence (specs)); fix_command (function, values); - call4 (intern ("add-to-history"), intern ("command-history"), + call4 (Qadd_to_history, Qcommand_history, Fcons (function, values), Qnil, Qt); } @@ -687,12 +687,12 @@ invoke it (via an `interactive' spec that contains, for instance, an break; case 'x': /* Lisp expression read but not evaluated. */ - args[i] = call1 (intern ("read-minibuffer"), callint_message); + args[i] = call1 (Qread_minibuffer, callint_message); visargs[i] = last_minibuf_string; break; case 'X': /* Lisp expression read and evaluated. */ - args[i] = call1 (intern ("eval-minibuffer"), callint_message); + args[i] = call1 (Qeval_minibuffer, callint_message); visargs[i] = last_minibuf_string; break; @@ -766,7 +766,7 @@ invoke it (via an `interactive' spec that contains, for instance, an visargs[i] = (varies[i] > 0 ? list1 (intern (callint_argfuns[varies[i]])) : quotify_arg (args[i])); - call4 (intern ("add-to-history"), intern ("command-history"), + call4 (Qadd_to_history, Qcommand_history, Flist (nargs - 1, visargs + 1), Qnil, Qt); } @@ -912,4 +912,7 @@ use `event-start', `event-end', and `event-click-count'. */); defsubr (&Sprefix_numeric_value); DEFSYM (Qinteractive_args, "interactive-args"); + DEFSYM (Qread_file_name, "read-file-name"); + DEFSYM (Qcommand_history, "command-history"); + DEFSYM (Qeval_minibuffer, "eval-minibuffer"); } diff --git a/src/callproc.c b/src/callproc.c index db36ef569e6..e116298baef 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -914,7 +914,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, /* If the caller required, let the buffer inherit the coding-system used to decode the process output. */ if (inherit_process_coding_system) - call1 (intern ("after-insert-file-set-buffer-file-coding-system"), + call1 (Qafter_insert_file_set_buffer_file_coding_system, make_fixnum (total_read)); } @@ -1041,7 +1041,7 @@ create_temp_file (ptrdiff_t nargs, Lisp_Object *args, { specpdl_ref count1 = SPECPDL_INDEX (); - specbind (intern ("coding-system-for-write"), val); + specbind (Qcoding_system_for_write, val); /* POSIX lets mk[s]temp use "."; don't invoke jka-compr if we happen to get a ".Z" suffix. */ specbind (Qfile_name_handler_alist, Qnil); @@ -2246,4 +2246,8 @@ the system. */); defsubr (&Scall_process); defsubr (&Sgetenv_internal); defsubr (&Scall_process_region); + + DEFSYM (Qafter_insert_file_set_buffer_file_coding_system, + "after-insert-file-set-buffer-file-coding-system"); + DEFSYM (Qcoding_system_for_write, "coding-system-for-write"); } diff --git a/src/charset.c b/src/charset.c index 4bacc011e85..675097c6843 100644 --- a/src/charset.c +++ b/src/charset.c @@ -862,7 +862,7 @@ usage: (define-charset-internal ...) */) if (nargs != charset_arg_max) Fsignal (Qwrong_number_of_arguments, - Fcons (intern ("define-charset-internal"), + Fcons (Qdefine_charset_internal, make_fixnum (nargs))); attrs = make_nil_vector (charset_attr_max); @@ -2354,6 +2354,7 @@ void syms_of_charset (void) { DEFSYM (Qcharsetp, "charsetp"); + DEFSYM (Qdefine_charset_internal, "define-charset-internal"); /* Special charset symbols. */ DEFSYM (Qascii, "ascii"); diff --git a/src/cmds.c b/src/cmds.c index 81788b07242..f7a3f9e7ac6 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -428,7 +428,7 @@ internal_self_insert (int c, EMACS_INT n) && SYMBOLP (XSYMBOL (sym)->u.s.function)) { Lisp_Object prop; - prop = Fget (XSYMBOL (sym)->u.s.function, intern ("no-self-insert")); + prop = Fget (XSYMBOL (sym)->u.s.function, Qno_self_insert); if (! NILP (prop)) return 1; } @@ -507,6 +507,7 @@ syms_of_cmds (void) DEFSYM (Qundo_auto_amalgamate, "undo-auto-amalgamate"); DEFSYM (Qundo_auto__this_command_amalgamating, "undo-auto--this-command-amalgamating"); + DEFSYM (Qno_self_insert, "no-self-insert"); DEFSYM (Qkill_forward_chars, "kill-forward-chars"); diff --git a/src/coding.c b/src/coding.c index c51ceb95475..5e4e92ea6e2 100644 --- a/src/coding.c +++ b/src/coding.c @@ -806,7 +806,7 @@ record_conversion_result (struct coding_system *coding, case CODING_RESULT_SUCCESS: break; default: - Vlast_code_conversion_error = intern ("Unknown error"); + Vlast_code_conversion_error = QUnknown_error; } } @@ -8109,7 +8109,7 @@ decode_coding_object (struct coding_system *coding, set_buffer_internal (XBUFFER (src_object)); if (from != GPT) move_gap_both (from, from_byte); - if (EQ (src_object, dst_object)) + if (BASE_EQ (src_object, dst_object)) { struct Lisp_Marker *tail; @@ -8121,8 +8121,9 @@ decode_coding_object (struct coding_system *coding, } saved_pt = PT, saved_pt_byte = PT_BYTE; TEMP_SET_PT_BOTH (from, from_byte); - current_buffer->text->inhibit_shrinking = 1; - del_range_both (from, from_byte, to, to_byte, 1); + current_buffer->text->inhibit_shrinking = true; + prepare_to_modify_buffer (from, to, NULL); + del_range_2 (from, from_byte, to, to_byte, false); coding->src_pos = -chars; coding->src_pos_byte = -bytes; } @@ -8148,6 +8149,13 @@ decode_coding_object (struct coding_system *coding, } else if (BUFFERP (dst_object)) { + if (!BASE_EQ (src_object, dst_object)) + { + struct buffer *current = current_buffer; + set_buffer_internal (XBUFFER (dst_object)); + prepare_to_modify_buffer (PT, PT, NULL); + set_buffer_internal (current); + } code_conversion_save (0, 0); coding->dst_object = dst_object; coding->dst_pos = BUF_PT (XBUFFER (dst_object)); @@ -8168,7 +8176,14 @@ decode_coding_object (struct coding_system *coding, decode_coding (coding); if (BUFFERP (coding->dst_object)) - set_buffer_internal (XBUFFER (coding->dst_object)); + { + set_buffer_internal (XBUFFER (coding->dst_object)); + signal_after_change (coding->dst_pos, + BASE_EQ (src_object, dst_object) ? to - from : 0, + coding->produced_char); + update_compositions (coding->dst_pos, + coding->dst_pos + coding->produced_char, CHECK_ALL); + } if (! NILP (CODING_ATTR_POST_READ (attrs))) { @@ -8373,7 +8388,12 @@ encode_coding_object (struct coding_system *coding, if (same_buffer) { saved_pt = PT, saved_pt_byte = PT_BYTE; - coding->src_object = del_range_1 (from, to, 1, 1); + /* Run 'prepare_to_modify_buffer' by hand because we don't want + to run the after-change hooks yet. */ + prepare_to_modify_buffer (from, to, &from); + coding->src_object = del_range_2 (from, CHAR_TO_BYTE (from), + to, CHAR_TO_BYTE (to), + true); coding->src_pos = 0; coding->src_pos_byte = 0; } @@ -8404,11 +8424,12 @@ encode_coding_object (struct coding_system *coding, { struct buffer *current = current_buffer; - set_buffer_temp (XBUFFER (dst_object)); + set_buffer_internal (XBUFFER (dst_object)); + prepare_to_modify_buffer (PT, PT, NULL); coding->dst_pos = PT; coding->dst_pos_byte = PT_BYTE; move_gap_both (coding->dst_pos, coding->dst_pos_byte); - set_buffer_temp (current); + set_buffer_internal (current); } coding->dst_multibyte = ! NILP (BVAR (XBUFFER (dst_object), enable_multibyte_characters)); @@ -8446,6 +8467,16 @@ encode_coding_object (struct coding_system *coding, xfree (coding->destination); } } + else if (BUFFERP (coding->dst_object)) + { + struct buffer *current = current_buffer; + set_buffer_internal (XBUFFER (dst_object)); + signal_after_change (coding->dst_pos, same_buffer ? to - from : 0, + coding->produced_char); + update_compositions (coding->dst_pos, + coding->dst_pos + coding->produced_char, CHECK_ALL); + set_buffer_internal (current); + } if (saved_pt >= 0) { @@ -9510,7 +9541,7 @@ not fully specified.) */) DEFUN ("encode-coding-region", Fencode_coding_region, Sencode_coding_region, 3, 4, "r\nzCoding system: ", - doc: /* Encode the current region using th specified coding system. + doc: /* Encode the current region using the specified coding system. Interactively, prompt for the coding system to encode the region, and replace the region with the bytes that are the result of the encoding. @@ -11477,7 +11508,7 @@ usage: (define-coding-system-internal ...) */) short_args: Fsignal (Qwrong_number_of_arguments, - Fcons (intern ("define-coding-system-internal"), + Fcons (Qdefine_coding_system_internal, make_fixnum (nargs))); } @@ -12260,6 +12291,9 @@ internal character representation. */); Fset (AREF (Vcoding_category_table, i), Qno_conversion); pdumper_do_now_and_after_load (reset_coding_after_pdumper_load); + + DEFSYM (QUnknown_error, "Unknown error"); + DEFSYM (Qdefine_coding_system_internal, "define-coding-system-internal"); } static void diff --git a/src/comp.c b/src/comp.c index 99f51e07048..4e779cdf898 100644 --- a/src/comp.c +++ b/src/comp.c @@ -744,7 +744,7 @@ static Lisp_Object comp_hash_string (Lisp_Object string) { Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); - md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + md5_buffer (SSDATA (string), SBYTES (string), SSDATA (digest)); hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); @@ -5199,7 +5199,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, if (!native_comp_jit_compilation || noninteractive || !NILP (Vpurify_flag) - || !COMPILEDP (definition) + || !CLOSUREP (definition) || !STRINGP (Vload_true_file_name) || !suffix_p (Vload_true_file_name, ".elc") || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil))) diff --git a/src/data.c b/src/data.c index c4b9cff8ae0..ea611ad1abf 100644 --- a/src/data.c +++ b/src/data.c @@ -248,7 +248,9 @@ a fixed set of types. */) return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp : Qprimitive_function; - case PVEC_COMPILED: return Qcompiled_function; + case PVEC_CLOSURE: + return CONSP (AREF (object, CLOSURE_CODE)) + ? Qinterpreted_function : Qbyte_code_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; case PVEC_BOOL_VECTOR: return Qbool_vector; @@ -518,12 +520,32 @@ DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, return Qnil; } +DEFUN ("closurep", Fclosurep, Sclosurep, + 1, 1, 0, + doc: /* Return t if OBJECT is a function of type `closure'. */) + (Lisp_Object object) +{ + if (CLOSUREP (object)) + return Qt; + return Qnil; +} + DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, 1, 1, 0, doc: /* Return t if OBJECT is a byte-compiled function object. */) (Lisp_Object object) { - if (COMPILEDP (object)) + if (CLOSUREP (object) && STRINGP (AREF (object, CLOSURE_CODE))) + return Qt; + return Qnil; +} + +DEFUN ("interpreted-function-p", Finterpreted_function_p, + Sinterpreted_function_p, 1, 1, 0, + doc: /* Return t if OBJECT is a function of type `interpreted-function'. */) + (Lisp_Object object) +{ + if (CLOSUREP (object) && CONSP (AREF (object, CLOSURE_CODE))) return Qt; return Qnil; } @@ -1143,19 +1165,19 @@ Value, if non-nil, is a list (interactive SPEC). */) (*spec != '(') ? build_string (spec) : Fcar (Fread_from_string (build_string (spec), Qnil, Qnil))); } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - if (PVSIZE (fun) > COMPILED_INTERACTIVE) + if (PVSIZE (fun) > CLOSURE_INTERACTIVE) { - Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + Lisp_Object form = AREF (fun, CLOSURE_INTERACTIVE); /* The vector form is the new form, where the first element is the interactive spec, and the second is the command modes. */ return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form); } - else if (PVSIZE (fun) > COMPILED_DOC_STRING) + else if (PVSIZE (fun) > CLOSURE_DOC_STRING) { - Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + Lisp_Object doc = AREF (fun, CLOSURE_DOC_STRING); /* An invalid "docstring" is a sign that we have an OClosure. */ genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); } @@ -1174,17 +1196,11 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure) - || EQ (funcar, Qlambda)) + if (EQ (funcar, Qlambda)) { Lisp_Object form = Fcdr (XCDR (fun)); - if (EQ (funcar, Qclosure)) - form = Fcdr (form); Lisp_Object spec = Fassq (Qinteractive, form); - if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form))) - /* A "docstring" is a sign that we may have an OClosure. */ - genfun = true; - else if (NILP (Fcdr (Fcdr (spec)))) + if (NILP (Fcdr (Fcdr (spec)))) return spec; else return list2 (Qinteractive, Fcar (Fcdr (spec))); @@ -1225,11 +1241,11 @@ The value, if non-nil, is a list of mode name symbols. */) { return XSUBR (fun)->command_modes; } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - if (PVSIZE (fun) <= COMPILED_INTERACTIVE) + if (PVSIZE (fun) <= CLOSURE_INTERACTIVE) return Qnil; - Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + Lisp_Object form = AREF (fun, CLOSURE_INTERACTIVE); if (VECTORP (form)) /* New form -- the second element is the command modes. */ return AREF (form, 1); @@ -1257,12 +1273,9 @@ The value, if non-nil, is a list of mode name symbols. */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure) - || EQ (funcar, Qlambda)) + if (EQ (funcar, Qlambda)) { Lisp_Object form = Fcdr (XCDR (fun)); - if (EQ (funcar, Qclosure)) - form = Fcdr (form); return Fcdr (Fcdr (Fassq (Qinteractive, form))); } } @@ -2546,7 +2559,7 @@ or a byte-code object. IDX starts at 0. */) ptrdiff_t size = 0; if (VECTORP (array)) size = ASIZE (array); - else if (COMPILEDP (array) || RECORDP (array)) + else if (CLOSUREP (array) || RECORDP (array)) size = PVSIZE (array); else wrong_type_argument (Qarrayp, array); @@ -4224,7 +4237,8 @@ syms_of_data (void) DEFSYM (Qspecial_form, "special-form"); DEFSYM (Qprimitive_function, "primitive-function"); DEFSYM (Qsubr_native_elisp, "subr-native-elisp"); - DEFSYM (Qcompiled_function, "compiled-function"); + DEFSYM (Qbyte_code_function, "byte-code-function"); + DEFSYM (Qinterpreted_function, "interpreted-function"); DEFSYM (Qbuffer, "buffer"); DEFSYM (Qframe, "frame"); DEFSYM (Qvector, "vector"); @@ -4289,6 +4303,8 @@ syms_of_data (void) defsubr (&Smarkerp); defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); + defsubr (&Sinterpreted_function_p); + defsubr (&Sclosurep); defsubr (&Smodule_function_p); defsubr (&Schar_or_string_p); defsubr (&Sthreadp); diff --git a/src/dbusbind.c b/src/dbusbind.c index 7069e27e3eb..9f93f2894c2 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -474,7 +474,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); if (strcmp (subsig, x) != 0) - wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt)); + wrong_type_argument (QD_Bus, CAR_SAFE (elt)); elt = CDR_SAFE (XD_NEXT_VALUE (elt)); } @@ -493,7 +493,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt)))) - wrong_type_argument (intern ("D-Bus"), + wrong_type_argument (QD_Bus, CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt)))); sprintf (signature, "%c", dtype); @@ -528,7 +528,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) /* Check the parent object type. */ if (parent_type != DBUS_TYPE_ARRAY) - wrong_type_argument (intern ("D-Bus"), object); + wrong_type_argument (QD_Bus, object); /* Compose the signature from the elements. It is enclosed by curly braces. */ @@ -542,7 +542,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) xd_signature_cat (signature, x); if (!XD_BASIC_DBUS_TYPE (subtype)) - wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt))); + wrong_type_argument (QD_Bus, CAR_SAFE (XD_NEXT_VALUE (elt))); /* Second element. */ elt = CDR_SAFE (XD_NEXT_VALUE (elt)); @@ -552,7 +552,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) xd_signature_cat (signature, x); if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt)))) - wrong_type_argument (intern ("D-Bus"), + wrong_type_argument (QD_Bus, CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt)))); /* Closing signature. */ @@ -560,7 +560,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) break; default: - wrong_type_argument (intern ("D-Bus"), object); + wrong_type_argument (QD_Bus, object); } XD_DEBUG_MESSAGE ("%s", signature); @@ -1480,7 +1480,7 @@ usage: (dbus-message-internal &rest REST) */) bus or an unknown name, we regard it as broadcast message due to backward compatibility. */ if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL)) - uname = call2 (intern ("dbus-get-name-owner"), bus, service); + uname = call2 (Qdbus_get_name_owner, bus, service); else uname = Qnil; @@ -1689,6 +1689,22 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) bus, build_string (interface), build_string (member)); value = Fgethash (key, Vdbus_registered_objects_table, Qnil); + /* A signal could be registered with a nil interface or member. */ + if (mtype == DBUS_MESSAGE_TYPE_SIGNAL) + { + key = list4 (QCsignal, bus, Qnil, build_string (member)); + value = CALLN (Fappend, value, + Fgethash (key, Vdbus_registered_objects_table, Qnil)); + + key = list4 (QCsignal, bus, build_string (interface), Qnil); + value = CALLN (Fappend, value, + Fgethash (key, Vdbus_registered_objects_table, Qnil)); + + key = list4 (QCsignal, bus, Qnil, Qnil); + value = CALLN (Fappend, value, + Fgethash (key, Vdbus_registered_objects_table, Qnil)); + } + /* Loop over the registered functions. Construct an event. */ for (; !NILP (value); value = CDR_SAFE (value)) { @@ -1870,6 +1886,7 @@ syms_of_dbusbind (void) list2 (Qdbus_error, Qerror)); Fput (Qdbus_error, Qerror_message, build_pure_c_string ("D-Bus error")); + DEFSYM (QD_Bus, "D-Bus"); /* Lisp symbols of the system and session buses. */ DEFSYM (QCsystem, ":system"); @@ -1908,6 +1925,9 @@ syms_of_dbusbind (void) DEFSYM (QCsignal, ":signal"); DEFSYM (QCmonitor, ":monitor"); + /* Miscellaneous Lisp symbols. */ + DEFSYM (Qdbus_get_name_owner, "dbus-get-name-owner"); + DEFVAR_LISP ("dbus-compiled-version", Vdbus_compiled_version, doc: /* The version of D-Bus Emacs is compiled against. */); diff --git a/src/dispextern.h b/src/dispextern.h index 1c3232fae3d..93cbde6583d 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -69,12 +69,6 @@ typedef struct unsigned width, height; } Emacs_Rectangle; -#else - -typedef struct android_rectangle Emacs_Rectangle; - -#endif - /* XGCValues-like struct used by non-X GUI code. */ typedef struct { @@ -88,6 +82,19 @@ typedef struct #define GCForeground 0x01 #define GCBackground 0x02 +#else + +typedef struct android_rectangle Emacs_Rectangle; +typedef struct android_gc_values Emacs_GC; + +#define GCForeground ANDROID_GC_FOREGROUND +#define GCBackground ANDROID_GC_BACKGROUND +#define GCFillStyle ANDROID_GC_FILL_STYLE +#define GCStipple ANDROID_GC_STIPPLE +#define FillOpaqueStippled ANDROID_FILL_OPAQUE_STIPPLED + +#endif + #endif /* HAVE_X_WINDOWS */ #ifdef MSDOS @@ -1690,9 +1697,15 @@ enum face_box_type enum face_underline_type { + /* Note: order matches the order of the Smulx terminfo extension, and + is also relied on to remain in its present order by + x_draw_glyph_string and company. */ FACE_NO_UNDERLINE = 0, - FACE_UNDER_LINE, - FACE_UNDER_WAVE + FACE_UNDERLINE_SINGLE, + FACE_UNDERLINE_DOUBLE_LINE, + FACE_UNDERLINE_WAVE, + FACE_UNDERLINE_DOTS, + FACE_UNDERLINE_DASHES, }; /* Structure describing a realized face. @@ -1776,7 +1789,7 @@ struct face ENUM_BF (face_box_type) box : 2; /* Style of underlining. */ - ENUM_BF (face_underline_type) underline : 2; + ENUM_BF (face_underline_type) underline : 3; /* If `box' above specifies a 3D type, true means use box_color for drawing shadows. */ @@ -1808,7 +1821,6 @@ struct face string meaning the default color of the TTY. */ bool_bf tty_bold_p : 1; bool_bf tty_italic_p : 1; - bool_bf tty_underline_p : 1; bool_bf tty_reverse_p : 1; bool_bf tty_strike_through_p : 1; @@ -2412,7 +2424,9 @@ struct it bool_bf string_from_display_prop_p : 1; /* True means `string' comes from a `line-prefix' or `wrap-prefix' - property. */ + property, and that these properties were already handled, even if + their value is not a string. This is used to avoid processing + the same line/wrap prefix more than once for the same glyph row. */ bool_bf string_from_prefix_prop_p : 1; /* True means we are iterating an object that came from a value of a @@ -3186,6 +3200,11 @@ struct image int face_font_size; char *face_font_family; + /* Details of the font used to calculate image size relative to the + canonical character size, with `ch' and `cw' specifiers. */ + int face_font_height; + int face_font_width; + /* True if this image has a `transparent' background -- that is, is uses an image mask. The accessor macro for this is `IMAGE_BACKGROUND_TRANSPARENT'. */ @@ -3421,6 +3440,7 @@ enum tool_bar_item_image #define TTY_CAP_DIM 0x08 #define TTY_CAP_ITALIC 0x10 #define TTY_CAP_STRIKE_THROUGH 0x20 +#define TTY_CAP_UNDERLINE_STYLED (0x32 & TTY_CAP_UNDERLINE) /*********************************************************************** diff --git a/src/dispnew.c b/src/dispnew.c index c204a9dbf1b..8eda8dbb358 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -6503,7 +6503,7 @@ init_faces_initial (void) FRAME_FOREGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_FG_COLOR; FRAME_BACKGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_BG_COLOR; - call0 (intern ("tty-set-up-initial-frame-faces")); + call0 (Qtty_set_up_initial_frame_faces); } /* Initialization done when Emacs fork is started, before doing stty. diff --git a/src/doc.c b/src/doc.c index b5a9ed498af..36633a920c6 100644 --- a/src/doc.c +++ b/src/doc.c @@ -517,11 +517,27 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) fun = XCDR (fun); /* Lisp_Subrs have a slot for it. */ - if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun)) + if (SUBRP (fun)) XSUBR (fun)->doc = offset; + else if (CLOSUREP (fun)) + { + /* This bytecode object must have a slot for the docstring, since + we've found a docstring for it. */ + if (PVSIZE (fun) > CLOSURE_DOC_STRING + /* Don't overwrite a non-docstring value placed there, such as + the symbols used for Oclosures. */ + && VALID_DOCSTRING_P (AREF (fun, CLOSURE_DOC_STRING))) + ASET (fun, CLOSURE_DOC_STRING, make_fixnum (offset)); + else + { + AUTO_STRING (format, "No doc string slot for compiled: %S"); + CALLN (Fmessage, format, obj); + } + } else { - AUTO_STRING (format, "Ignoring DOC string on non-subr: %S"); + AUTO_STRING (format, "Ignoring DOC string on non-compiled" + "non-subr: %S"); CALLN (Fmessage, format, obj); } } @@ -548,8 +564,8 @@ the same file name is found in the `doc-directory'. */) ptrdiff_t dirlen; /* Preloaded defcustoms using custom-initialize-delay are added to this list, but kept unbound. See https://debbugs.gnu.org/11565 */ - Lisp_Object delayed_init = - find_symbol_value (intern ("custom-delayed-init-variables")); + Lisp_Object delayed_init + = find_symbol_value (Qcustom_delayed_init_variables); if (!CONSP (delayed_init)) delayed_init = Qnil; @@ -763,4 +779,5 @@ compute the correct value for the current terminal in the nil case. */); defsubr (&Sdocumentation_property); defsubr (&Ssnarf_documentation); defsubr (&Stext_quoting_style); + DEFSYM (Qcustom_delayed_init_variables, "custom-delayed-init-variables"); } diff --git a/src/dosfns.c b/src/dosfns.c index 96087116c19..f883c7a8b8a 100644 --- a/src/dosfns.c +++ b/src/dosfns.c @@ -563,7 +563,7 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qtime, tem), attrs); attrs = Fcons (Fcons (Qthcount, make_fixnum (1)), attrs); attrs = Fcons (Fcons (Qstart, - Fsymbol_value (intern ("before-init-time"))), + Fsymbol_value (Qbefore_init_time)), attrs); attrs = Fcons (Fcons (Qvsize, INT_TO_INTEGER ((unsigned long) sbrk (0) / 1024)), @@ -794,5 +794,6 @@ If non-zero, this variable contains the character to be returned when the decimal point key in the numeric keypad is pressed when Num Lock is on. If zero, the decimal point key returns the country code specific value. */); dos_decimal_point = 0; + DEFSYM (Qbefore_init_time, "before-init-time"); } #endif /* MSDOS */ diff --git a/src/editfns.c b/src/editfns.c index 4ccf765bd4b..fbfaaf66644 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -370,7 +370,7 @@ at POSITION. */) Either BEG or END may be 0, in which case the corresponding value is not stored. */ -static void +void find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, Lisp_Object beg_limit, ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end) diff --git a/src/emacs.c b/src/emacs.c index 87f12d3fa86..22da39a4d1c 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -565,9 +565,8 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) { if (NILP (Vpurify_flag)) { - Lisp_Object file_truename = intern ("file-truename"); - if (!NILP (Ffboundp (file_truename))) - dir = call1 (file_truename, dir); + if (!NILP (Ffboundp (Qfile_truename))) + dir = call1 (Qfile_truename, dir); } dir = Fexpand_file_name (build_string ("../.."), dir); } @@ -1653,6 +1652,7 @@ main (int argc, char **argv) inhibit_window_system = 0; /* Handle the -t switch, which specifies filename to use as terminal. */ + dev_tty = xstrdup (DEV_TTY); /* the default terminal */ while (!only_version) { char *term; @@ -1675,6 +1675,8 @@ main (int argc, char **argv) exit (EXIT_FAILURE); } fprintf (stderr, "Using %s\n", term); + xfree (dev_tty); + dev_tty = xstrdup (term); #ifdef HAVE_WINDOW_SYSTEM inhibit_window_system = true; /* -t => -nw */ #endif @@ -2013,10 +2015,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_random (); init_xfaces (); -#if defined HAVE_JSON && !defined WINDOWSNT - init_json (); -#endif - if (!initialized) syms_of_comp (); @@ -2479,10 +2477,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_threads (); syms_of_profiler (); syms_of_pdumper (); - -#ifdef HAVE_JSON syms_of_json (); -#endif keys_of_keyboard (); @@ -3006,6 +3001,21 @@ killed. */ #ifdef HAVE_NATIVE_COMP eln_load_path_final_clean_up (); #endif +#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY + if (android_init_gui) + { + /* Calls to exit may be followed by illegal accesses from + toolkit-managed threads as the thread group is destroyed, which + are inconsequential when the process is being terminated, but + which must be suppressed to inhibit reporting of superfluous + crashes by the system. + + Execution won't return to Emacs whatever the value of RESTART, + as `android_restart_emacs' will only ever abort or succeed. */ + signal (SIGBUS, SIG_IGN); + signal (SIGSEGV, SIG_IGN); + } +#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */ if (!NILP (restart)) { @@ -3183,7 +3193,7 @@ You must run Emacs in batch mode in order to dump it. */) /* Bind `command-line-processed' to nil before dumping, so that the dumped Emacs will process its command line and set up to work with X windows if appropriate. */ - symbol = intern ("command-line-processed"); + symbol = Qcommand_line_processed; specbind (symbol, Qnil); CHECK_STRING (filename); @@ -3434,7 +3444,7 @@ decode_env_path (const char *evarname, const char *defalt, bool empty) if (SYMBOLP (tem)) { Lisp_Object prop; - prop = Fget (tem, intern ("safe-magic")); + prop = Fget (tem, Qsafe_magic); if (! NILP (prop)) tem = Qnil; } @@ -3543,6 +3553,9 @@ syms_of_emacs (void) DEFSYM (Qkill_emacs_hook, "kill-emacs-hook"); DEFSYM (Qrun_hook_query_error_with_timeout, "run-hook-query-error-with-timeout"); + DEFSYM (Qfile_truename, "file-truename"); + DEFSYM (Qcommand_line_processed, "command-line-processed"); + DEFSYM (Qsafe_magic, "safe-magic"); #ifdef HAVE_UNEXEC defsubr (&Sdump_emacs); diff --git a/src/epaths.in b/src/epaths.in index 275d13985aa..8415ce51586 100644 --- a/src/epaths.in +++ b/src/epaths.in @@ -95,7 +95,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # define PATH_DOC "/assets/etc/" # define PATH_INFO "/assets/info/" # define PATH_GAME "" - # define PATH_BITMAPS "" + # define PATH_BITMAPS "/assets/bitmaps/" extern char *android_site_load_path; extern char *android_lib_dir; diff --git a/src/eval.c b/src/eval.c index f48d7b0682f..637c874871d 100644 --- a/src/eval.c +++ b/src/eval.c @@ -292,7 +292,7 @@ call_debugger (Lisp_Object arg) displayed if the debugger is invoked during redisplay. */ debug_while_redisplaying = redisplaying_p; redisplaying_p = 0; - specbind (intern ("debugger-may-continue"), + specbind (Qdebugger_may_continue, debug_while_redisplaying ? Qnil : Qt); specbind (Qinhibit_redisplay, Qnil); specbind (Qinhibit_debugger, Qt); @@ -510,6 +510,33 @@ usage: (quote ARG) */) return XCAR (args); } +DEFUN ("make-interpreted-closure", Fmake_interpreted_closure, + Smake_interpreted_closure, 3, 5, 0, + doc: /* Make an interpreted closure. +ARGS should be the list of formal arguments. +BODY should be a non-empty list of forms. +ENV should be a lexical environment, like the second argument of `eval'. +IFORM if non-nil should be of the form (interactive ...). */) + (Lisp_Object args, Lisp_Object body, Lisp_Object env, + Lisp_Object docstring, Lisp_Object iform) +{ + CHECK_CONS (body); /* Make sure it's not confused with byte-code! */ + CHECK_LIST (args); + CHECK_LIST (iform); + Lisp_Object ifcdr = Fcdr (iform); + Lisp_Object slots[] = { args, body, env, Qnil, docstring, + NILP (Fcdr (ifcdr)) + ? Fcar (ifcdr) + : CALLN (Fvector, XCAR (ifcdr), XCDR (ifcdr)) }; + /* Adjusting the size is indispensable since, as for byte-code objects, + we distinguish interactive functions by the presence or absence of the + iform slot. */ + Lisp_Object val + = Fvector (!NILP (iform) ? 6 : !NILP (docstring) ? 5 : 3, slots); + XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); + return val; +} + DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, doc: /* Like `quote', but preferred for objects which are functions. In byte compilation, `function' causes its argument to be handled by @@ -525,33 +552,55 @@ usage: (function ARG) */) if (!NILP (XCDR (args))) xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); - if (!NILP (Vinternal_interpreter_environment) - && CONSP (quoted) + if (CONSP (quoted) && EQ (XCAR (quoted), Qlambda)) { /* This is a lambda expression within a lexical environment; return an interpreted closure instead of a simple lambda. */ Lisp_Object cdr = XCDR (quoted); - Lisp_Object tmp = cdr; - if (CONSP (tmp) - && (tmp = XCDR (tmp), CONSP (tmp)) - && (tmp = XCAR (tmp), CONSP (tmp)) - && (EQ (QCdocumentation, XCAR (tmp)))) - { /* Handle the special (:documentation <form>) to build the docstring + Lisp_Object args = Fcar (cdr); + cdr = Fcdr (cdr); + Lisp_Object docstring = Qnil, iform = Qnil; + if (CONSP (cdr)) + { + docstring = XCAR (cdr); + if (STRINGP (docstring)) + { + Lisp_Object tmp = XCDR (cdr); + if (!NILP (tmp)) + cdr = tmp; + else /* It's not a docstring, it's a return value. */ + docstring = Qnil; + } + /* 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)))); - } - if (NILP (Vinternal_make_interpreted_closure_function)) - return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, cdr)); + else if (CONSP (docstring) + && EQ (QCdocumentation, XCAR (docstring)) + && (docstring = eval_sub (Fcar (XCDR (docstring))), + true)) + cdr = XCDR (cdr); + else + docstring = Qnil; /* Not a docstring after all. */ + } + if (CONSP (cdr)) + { + iform = XCAR (cdr); + if (CONSP (iform) + && EQ (Qinteractive, XCAR (iform))) + cdr = XCDR (cdr); + else + iform = Qnil; /* Not an interactive-form after all. */ + } + if (NILP (cdr)) + cdr = Fcons (Qnil, Qnil); /* Make sure the body is never empty! */ + + if (NILP (Vinternal_interpreter_environment) + || NILP (Vinternal_make_interpreted_closure_function)) + return Fmake_interpreted_closure + (args, cdr, Vinternal_interpreter_environment, docstring, iform); else - return call2 (Vinternal_make_interpreted_closure_function, - Fcons (Qlambda, cdr), - Vinternal_interpreter_environment); + return call5 (Vinternal_make_interpreted_closure_function, + args, cdr, Vinternal_interpreter_environment, + docstring, iform); } else /* Simply quote the argument. */ @@ -619,8 +668,8 @@ signal a `cyclic-variable-indirection' error. */) else if (!NILP (Fboundp (new_alias)) && !EQ (find_symbol_value (new_alias), find_symbol_value (base_variable))) - call2 (intern ("display-warning"), - list3 (Qdefvaralias, intern ("losing-value"), new_alias), + call2 (Qdisplay_warning, + list3 (Qdefvaralias, Qlosing_value, new_alias), CALLN (Fformat_message, build_string ("Overwriting value of `%s' by aliasing to `%s'"), @@ -948,8 +997,9 @@ usage: (let* VARLIST BODY...) */) val = eval_sub (Fcar (XCDR (elt))); } - if (!NILP (lexenv) && SYMBOLP (var) - && !XSYMBOL (var)->u.s.declared_special + var = maybe_remove_pos_from_symbol (var); + if (!NILP (lexenv) && BARE_SYMBOL_P (var) + && !XBARE_SYMBOL (var)->u.s.declared_special && NILP (Fmemq (var, Vinternal_interpreter_environment))) /* Lexically bind VAR by adding it to the interpreter's binding alist. */ @@ -1016,11 +1066,10 @@ usage: (let VARLIST BODY...) */) varlist = XCAR (args); for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++) { - Lisp_Object var; - elt = XCAR (varlist); varlist = XCDR (varlist); - var = SYMBOLP (elt) ? elt : Fcar (elt); + Lisp_Object var = maybe_remove_pos_from_symbol (SYMBOLP (elt) ? elt + : Fcar (elt)); tem = temps[argnum]; if (!NILP (lexenv) && SYMBOLP (var) @@ -1188,6 +1237,12 @@ usage: (catch TAG BODY...) */) return internal_catch (tag, Fprogn, XCDR (args)); } +/* Work around GCC bug 61118 + <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=61118>. */ +#if GNUC_PREREQ (4, 9, 0) +# pragma GCC diagnostic ignored "-Wclobbered" +#endif + /* Assert that E is true, but do not evaluate E. Use this instead of eassert (E) when E contains variables that might be clobbered by a longjmp. */ @@ -1416,6 +1471,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, struct handler *oldhandlerlist = handlerlist; ptrdiff_t CACHEABLE clausenb = 0; + var = maybe_remove_pos_from_symbol (var); CHECK_SYMBOL (var); Lisp_Object success_handler = Qnil; @@ -2150,15 +2206,15 @@ then strings and vectors are not accepted. */) return Qt; } /* Bytecode objects are interactive if they are long enough to - have an element whose index is COMPILED_INTERACTIVE, which is + have an element whose index is CLOSURE_INTERACTIVE, which is where the interactive spec is stored. */ - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - if (PVSIZE (fun) > COMPILED_INTERACTIVE) + if (PVSIZE (fun) > CLOSURE_INTERACTIVE) return Qt; - else if (PVSIZE (fun) > COMPILED_DOC_STRING) + else if (PVSIZE (fun) > CLOSURE_DOC_STRING) { - Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + Lisp_Object doc = AREF (fun, CLOSURE_DOC_STRING); /* An invalid "docstring" is a sign that we have an OClosure. */ genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); } @@ -2192,15 +2248,12 @@ then strings and vectors are not accepted. */) else { Lisp_Object body = CDR_SAFE (XCDR (fun)); - if (EQ (funcar, Qclosure)) - body = CDR_SAFE (body); - else if (!EQ (funcar, Qlambda)) + if (!EQ (funcar, Qlambda)) return Qnil; if (!NILP (Fassq (Qinteractive, body))) return Qt; - else if (VALID_DOCSTRING_P (CAR_SAFE (body))) - /* A "docstring" is a sign that we may have an OClosure. */ - genfun = true; + else + return Qnil; } } @@ -2566,7 +2619,7 @@ eval_sub (Lisp_Object form) } } } - else if (COMPILEDP (fun) + else if (CLOSUREP (fun) || SUBR_NATIVE_COMPILED_DYNP (fun) || MODULE_FUNCTIONP (fun)) return apply_lambda (fun, original_args, count); @@ -2610,8 +2663,7 @@ eval_sub (Lisp_Object form) exp = unbind_to (count1, exp); val = eval_sub (exp); } - else if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) + else if (EQ (funcar, Qlambda)) return apply_lambda (fun, original_args, count); else xsignal1 (Qinvalid_function, original_fun); @@ -2944,12 +2996,12 @@ FUNCTIONP (Lisp_Object object) if (SUBRP (object)) return XSUBR (object)->max_args != UNEVALLED; - else if (COMPILEDP (object) || MODULE_FUNCTIONP (object)) + else if (CLOSUREP (object) || MODULE_FUNCTIONP (object)) return true; else if (CONSP (object)) { Lisp_Object car = XCAR (object); - return EQ (car, Qlambda) || EQ (car, Qclosure); + return EQ (car, Qlambda); } else return false; @@ -2966,7 +3018,7 @@ funcall_general (Lisp_Object fun, ptrdiff_t numargs, Lisp_Object *args) if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) return funcall_subr (XSUBR (fun), numargs, args); - else if (COMPILEDP (fun) + else if (CLOSUREP (fun) || SUBR_NATIVE_COMPILED_DYNP (fun) || MODULE_FUNCTIONP (fun)) return funcall_lambda (fun, numargs, args); @@ -2979,8 +3031,7 @@ funcall_general (Lisp_Object fun, ptrdiff_t numargs, Lisp_Object *args) Lisp_Object funcar = XCAR (fun); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original_fun); - if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) + if (EQ (funcar, Qlambda)) return funcall_lambda (fun, numargs, args); else if (EQ (funcar, Qautoload)) { @@ -3158,44 +3209,33 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, specpdl_ref count) or a module function. */ static Lisp_Object -funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, - register Lisp_Object *arg_vector) +funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, Lisp_Object *arg_vector) { - Lisp_Object val, syms_left, next, lexenv; - specpdl_ref count = SPECPDL_INDEX (); - ptrdiff_t i; - bool optional, rest; + Lisp_Object syms_left, lexenv; if (CONSP (fun)) { - if (EQ (XCAR (fun), Qclosure)) - { - Lisp_Object cdr = XCDR (fun); /* Drop `closure'. */ - if (! CONSP (cdr)) - xsignal1 (Qinvalid_function, fun); - fun = cdr; - lexenv = XCAR (fun); - } - else - lexenv = Qnil; + lexenv = Qnil; syms_left = XCDR (fun); if (CONSP (syms_left)) syms_left = XCAR (syms_left); else xsignal1 (Qinvalid_function, fun); } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - syms_left = AREF (fun, COMPILED_ARGLIST); + syms_left = AREF (fun, CLOSURE_ARGLIST); /* Bytecode objects using lexical binding have an integral ARGLIST slot value: pass the arguments to the byte-code engine directly. */ if (FIXNUMP (syms_left)) return exec_byte_code (fun, XFIXNUM (syms_left), nargs, arg_vector); - /* Otherwise the bytecode object uses dynamic binding and the - ARGLIST slot contains a standard formal argument list whose - variables are bound dynamically below. */ - lexenv = Qnil; + /* Otherwise the closure either is interpreted + or uses dynamic binding and the ARGLIST slot contains a standard + formal argument list whose variables are bound dynamically below. */ + lexenv = CONSP (AREF (fun, CLOSURE_CODE)) + ? AREF (fun, CLOSURE_CONSTANTS) + : Qnil; } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -3211,13 +3251,16 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else emacs_abort (); - i = optional = rest = 0; + specpdl_ref count = SPECPDL_INDEX (); + ptrdiff_t i = 0; + bool optional = false; + bool rest = false; bool previous_rest = false; for (; CONSP (syms_left); syms_left = XCDR (syms_left)) { maybe_quit (); - next = XCAR (syms_left); + Lisp_Object next = XCAR (syms_left); if (!SYMBOLP (next)) xsignal1 (Qinvalid_function, fun); @@ -3255,7 +3298,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, lexenv = Fcons (Fcons (next, arg), lexenv); else /* Dynamically bind NEXT. */ - specbind (next, arg); + specbind (maybe_remove_pos_from_symbol (next), arg); previous_rest = false; } } @@ -3269,6 +3312,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, /* Instantiate a new lexical environment. */ specbind (Qinternal_interpreter_environment, lexenv); + Lisp_Object val; if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); else if (SUBR_NATIVE_COMPILEDP (fun)) @@ -3279,7 +3323,14 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, val = XSUBR (fun)->function.a0 (); } else - val = exec_byte_code (fun, 0, 0, NULL); + { + eassert (CLOSUREP (fun)); + val = CONSP (AREF (fun, CLOSURE_CODE)) + /* Interpreted function. */ + ? Fprogn (AREF (fun, CLOSURE_CODE)) + /* Dynbound bytecode. */ + : exec_byte_code (fun, 0, 0, NULL); + } return unbind_to (count, val); } @@ -3314,7 +3365,7 @@ function with `&rest' args, or `unevalled' for a special form. */) if (SUBRP (function)) result = Fsubr_arity (function); - else if (COMPILEDP (function)) + else if (CLOSUREP (function)) result = lambda_arity (function); #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (function)) @@ -3329,8 +3380,7 @@ function with `&rest' args, or `unevalled' for a special form. */) funcar = XCAR (function); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original); - if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) + if (EQ (funcar, Qlambda)) result = lambda_arity (function); else if (EQ (funcar, Qautoload)) { @@ -3351,20 +3401,15 @@ lambda_arity (Lisp_Object fun) if (CONSP (fun)) { - if (EQ (XCAR (fun), Qclosure)) - { - fun = XCDR (fun); /* Drop `closure'. */ - CHECK_CONS (fun); - } syms_left = XCDR (fun); if (CONSP (syms_left)) syms_left = XCAR (syms_left); else xsignal1 (Qinvalid_function, fun); } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - syms_left = AREF (fun, COMPILED_ARGLIST); + syms_left = AREF (fun, CLOSURE_ARGLIST); if (FIXNUMP (syms_left)) return get_byte_code_arity (syms_left); } @@ -3466,10 +3511,8 @@ do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, void specbind (Lisp_Object symbol, Lisp_Object value) { - struct Lisp_Symbol *sym; - - CHECK_SYMBOL (symbol); - sym = XSYMBOL (symbol); + /* The caller must ensure that the SYMBOL argument is a bare symbol. */ + struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol); start: switch (sym->u.s.redirect) @@ -4266,11 +4309,13 @@ before making `inhibit-quit' nil. */); DEFSYM (Qcommandp, "commandp"); DEFSYM (Qand_rest, "&rest"); DEFSYM (Qand_optional, "&optional"); - DEFSYM (Qclosure, "closure"); DEFSYM (QCdocumentation, ":documentation"); DEFSYM (Qdebug, "debug"); DEFSYM (Qdebug_early, "debug-early"); DEFSYM (Qdebug_early__handler, "debug-early--handler"); + DEFSYM (Qdebugger_may_continue, "debugger-may-continue"); + DEFSYM (Qdisplay_warning, "display-warning"); + DEFSYM (Qlosing_value, "losing-value"); DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger, doc: /* Non-nil means never enter the debugger. @@ -4424,6 +4469,7 @@ alist of active lexical bindings. */); defsubr (&Ssetq); defsubr (&Squote); defsubr (&Sfunction); + defsubr (&Smake_interpreted_closure); defsubr (&Sdefault_toplevel_value); defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); diff --git a/src/fileio.c b/src/fileio.c index 12da7a9ed3a..960a3b21dc0 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -2205,7 +2205,7 @@ barf_or_query_if_file_exists (Lisp_Object absname, bool known_to_exist, AUTO_STRING (format, "File %s already exists; %s anyway? "); tem = CALLN (Fformat, format, absname, build_string (querystring)); if (quick) - tem = call1 (intern ("y-or-n-p"), tem); + tem = call1 (Qy_or_n_p, tem); else tem = do_yes_or_no_p (tem); if (NILP (tem)) @@ -4550,7 +4550,7 @@ by calling `format-decode', which see. */) current_buffer->modtime earlier, but we could still end up calling ask-user-about-supersession-threat if the file is modified while we read it, so we bind buffer-file-name instead. */ - specbind (intern ("buffer-file-name"), Qnil); + specbind (Qbuffer_file_name, Qnil); del_range_byte (same_at_start, same_at_end); /* Insert from the file at the proper position. */ temp = BYTE_TO_CHAR (same_at_start); @@ -4660,7 +4660,7 @@ by calling `format-decode', which see. */) if (same_at_start != same_at_end) { /* See previous specbind for the reason behind this. */ - specbind (intern ("buffer-file-name"), Qnil); + specbind (Qbuffer_file_name, Qnil); del_range_byte (same_at_start, same_at_end); } inserted = 0; @@ -4710,7 +4710,7 @@ by calling `format-decode', which see. */) inserted -= (ZV_BYTE - same_at_end) + (same_at_start - BEGV_BYTE); /* See previous specbind for the reason behind this. */ - specbind (intern ("buffer-file-name"), Qnil); + specbind (Qbuffer_file_name, Qnil); if (same_at_end != same_at_start) { del_range_byte (same_at_start, same_at_end); @@ -6107,8 +6107,8 @@ auto_save_error (Lisp_Object error_val) AUTO_STRING (format, "Auto-saving %s: %s"); Lisp_Object msg = CALLN (Fformat, format, BVAR (current_buffer, name), Ferror_message_string (error_val)); - call3 (intern ("display-warning"), - intern ("auto-save"), msg, intern (":error")); + call3 (Qdisplay_warning, + Qauto_save, msg, QCerror); return Qnil; } @@ -6223,7 +6223,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) oquit = Vquit_flag; Vquit_flag = Qnil; - hook = intern ("auto-save-hook"); + hook = Qauto_save_hook; safe_run_hooks (hook); if (STRINGP (Vauto_save_list_file_name)) @@ -6914,4 +6914,8 @@ This includes interactive calls to `delete-file' and #endif /* HAVE_SYNC */ DEFSYM (Qif_regular, "if-regular"); + DEFSYM (Qbuffer_file_name, "buffer-file-name"); + DEFSYM (Qauto_save, "auto-save"); + DEFSYM (QCerror, ":error"); + DEFSYM (Qauto_save_hook, "auto-save-hook"); } diff --git a/src/filelock.c b/src/filelock.c index 8c27b226900..050cac565c9 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -274,7 +274,7 @@ lock_file_1 (Lisp_Object lfname, bool force) /* Protect against the extremely unlikely case of the host name containing an @ character. */ if (!NILP (lhost_name) && strchr (SSDATA (lhost_name), '@')) - lhost_name = CALLN (Ffuncall, intern ("string-replace"), + lhost_name = CALLN (Ffuncall, Qstring_replace, build_string ("@"), build_string ("-"), lhost_name); @@ -419,7 +419,9 @@ current_lock_owner (lock_info_type *owner, Lisp_Object lfname) boot += 2; FALLTHROUGH; case ':': - if (! c_isdigit (boot[0])) + if (!(c_isdigit (boot[0]) + /* A negative number. */ + || (boot[0] == '-' && c_isdigit (boot[1])))) return EINVAL; boot_time = strtoimax (boot, &lfinfo_end, 10); break; @@ -638,8 +640,11 @@ unlock_all_files (void) } DEFUN ("lock-file", Flock_file, Slock_file, 1, 1, 0, - doc: /* Lock FILE. -If the option `create-lockfiles' is nil, this does nothing. */) + doc: /* Check whether FILE was modified since it was visited, and lock it. +If user option `create-lockfiles' is nil, this does not create +a lock file for FILE, but it still checks whether FILE was modified +outside of the current Emacs session, and if so, asks the user +whether to modify FILE. */) (Lisp_Object file) { #ifndef MSDOS @@ -786,6 +791,7 @@ Info node `(emacs)Interlocking'. */); DEFSYM (Qunlock_file, "unlock-file"); DEFSYM (Qfile_locked_p, "file-locked-p"); DEFSYM (Qmake_lock_file_name, "make-lock-file-name"); + DEFSYM (Qstring_replace, "string-replace"); defsubr (&Slock_file); defsubr (&Sunlock_file); diff --git a/src/fns.c b/src/fns.c index db5e856d5bd..9be42aa8b68 100644 --- a/src/fns.c +++ b/src/fns.c @@ -152,7 +152,7 @@ efficient. */) val = MAX_CHAR; else if (BOOL_VECTOR_P (sequence)) val = bool_vector_size (sequence); - else if (COMPILEDP (sequence) || RECORDP (sequence)) + else if (CLOSUREP (sequence) || RECORDP (sequence)) val = PVSIZE (sequence); else wrong_type_argument (Qsequencep, sequence); @@ -481,7 +481,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) int d = memcmp (SSDATA (string1), SSDATA (string2), n); if (d) return d; - return n < SCHARS (string2) ? -1 : n > SCHARS (string2); + return n < SCHARS (string2) ? -1 : n < SCHARS (string1); } else if (STRING_MULTIBYTE (string1) && STRING_MULTIBYTE (string2)) { @@ -515,7 +515,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) if (b >= nb) /* One string is a prefix of the other. */ - return b < nb2 ? -1 : b > nb2; + return b < nb2 ? -1 : b < nb1; /* Now back up to the start of the differing characters: it's the last byte not having the bit pattern 10xxxxxx. */ @@ -540,7 +540,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) if (c1 != c2) return c1 < c2 ? -1 : 1; } - return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2); + return i1 < SCHARS (string2) ? -1 : i1 < SCHARS (string1); } else { @@ -553,7 +553,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) if (c1 != c2) return c1 < c2 ? -1 : 1; } - return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2); + return i1 < SCHARS (string2) ? -1 : i1 < SCHARS (string1); } } @@ -1054,7 +1054,7 @@ concat_to_list (ptrdiff_t nargs, Lisp_Object *args, Lisp_Object last_tail) else if (NILP (arg)) ; else if (VECTORP (arg) || STRINGP (arg) - || BOOL_VECTOR_P (arg) || COMPILEDP (arg)) + || BOOL_VECTOR_P (arg) || CLOSUREP (arg)) { ptrdiff_t arglen = XFIXNUM (Flength (arg)); ptrdiff_t argindex_byte = 0; @@ -1114,7 +1114,7 @@ concat_to_vector (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object arg = args[i]; if (!(VECTORP (arg) || CONSP (arg) || NILP (arg) || STRINGP (arg) - || BOOL_VECTOR_P (arg) || COMPILEDP (arg))) + || BOOL_VECTOR_P (arg) || CLOSUREP (arg))) wrong_type_argument (Qsequencep, arg); EMACS_INT len = XFIXNAT (Flength (arg)); result_len += len; @@ -1170,7 +1170,7 @@ concat_to_vector (ptrdiff_t nargs, Lisp_Object *args) } else { - eassert (COMPILEDP (arg)); + eassert (CLOSUREP (arg)); ptrdiff_t size = PVSIZE (arg); memcpy (dst, XVECTOR (arg)->contents, size * sizeof *dst); dst += size; @@ -2949,7 +2949,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, if (size & PSEUDOVECTOR_FLAG) { if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS) - < PVEC_COMPILED) + < PVEC_CLOSURE) return false; size &= PSEUDOVECTOR_SIZE_MASK; } @@ -3346,7 +3346,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) tail = XCDR (tail); } } - else if (VECTORP (seq) || COMPILEDP (seq)) + else if (VECTORP (seq) || CLOSUREP (seq)) { for (ptrdiff_t i = 0; i < leni; i++) { @@ -5512,7 +5512,7 @@ sxhash_obj (Lisp_Object obj, int depth) case Lisp_Vectorlike: { enum pvec_type pvec_type = PSEUDOVECTOR_TYPE (XVECTOR (obj)); - if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_COMPILED)) + if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_CLOSURE)) { /* According to the CL HyperSpec, two arrays are equal only if they are 'eq', except for strings and bit-vectors. In diff --git a/src/fontset.c b/src/fontset.c index d27fa22015e..a98d75606b3 100644 --- a/src/fontset.c +++ b/src/fontset.c @@ -1366,10 +1366,11 @@ free_realized_fontsets (Lisp_Object base) if (CHAR_TABLE_P (this) && EQ (FONTSET_BASE (this), base)) { Fclear_face_cache (Qt); - /* This is in case some Lisp calls this function and then - proceeds with calling some other function, like font-at, - which needs the basic faces. */ - recompute_basic_faces (XFRAME (FONTSET_FRAME (this))); + if (FRAME_LIVE_P (XFRAME (FONTSET_FRAME (this)))) + /* This is in case some Lisp calls this function and then + proceeds with calling some other function, like font-at, + which needs the basic faces. */ + recompute_basic_faces (XFRAME (FONTSET_FRAME (this))); break; } } @@ -1822,7 +1823,7 @@ fontset_from_font (Lisp_Object font_object) if (CONSP (val)) return XFIXNUM (FONTSET_ID (XCDR (val))); if (num_auto_fontsets++ == 0) - alias = intern ("fontset-startup"); + alias = Qfontset_startup; else { char temp[sizeof "fontset-auto" + INT_STRLEN_BOUND (ptrdiff_t)]; @@ -2173,6 +2174,7 @@ syms_of_fontset (void) Fput (Qfontset, Qchar_table_extra_slots, make_fixnum (8)); DEFSYM (Qfontset_info, "fontset-info"); Fput (Qfontset_info, Qchar_table_extra_slots, make_fixnum (1)); + DEFSYM (Qfontset_startup, "fontset-startup"); DEFSYM (Qappend, "append"); DEFSYM (Qlatin, "latin"); diff --git a/src/frame.c b/src/frame.c index abd6ef00901..80aa4a4a2e8 100644 --- a/src/frame.c +++ b/src/frame.c @@ -1001,6 +1001,7 @@ make_frame (bool mini_p) f->conversion.compose_region_start = Qnil; f->conversion.compose_region_end = Qnil; f->conversion.compose_region_overlay = Qnil; + f->conversion.field = Qnil; f->conversion.batch_edit_count = 0; f->conversion.batch_edit_flags = 0; f->conversion.actions = NULL; @@ -1113,12 +1114,12 @@ make_frame_without_minibuffer (Lisp_Object mini_window, KBOARD *kb, if (!FRAMEP (KVAR (kb, Vdefault_minibuffer_frame)) || ! FRAME_LIVE_P (XFRAME (KVAR (kb, Vdefault_minibuffer_frame)))) { - Lisp_Object frame_dummy; + Lisp_Object initial_frame; - XSETFRAME (frame_dummy, f); /* If there's no minibuffer frame to use, create one. */ - kset_default_minibuffer_frame - (kb, call1 (intern ("make-initial-minibuffer-frame"), display)); + initial_frame = call1 (Qmake_initial_minibuffer_frame, + display); + kset_default_minibuffer_frame (kb, initial_frame); } mini_window @@ -6267,6 +6268,7 @@ syms_of_frame (void) DEFSYM (Qframe_windows_min_size, "frame-windows-min-size"); DEFSYM (Qframe_monitor_attributes, "frame-monitor-attributes"); DEFSYM (Qwindow__pixel_to_total, "window--pixel-to-total"); + DEFSYM (Qmake_initial_minibuffer_frame, "make-initial-minibuffer-frame"); DEFSYM (Qexplicit_name, "explicit-name"); DEFSYM (Qheight, "height"); DEFSYM (Qicon, "icon"); @@ -6383,6 +6385,7 @@ syms_of_frame (void) DEFSYM (Qchild_frame_border_width, "child-frame-border-width"); DEFSYM (Qinternal_border_width, "internal-border-width"); DEFSYM (Qleft_fringe, "left-fringe"); + DEFSYM (Qleft_fringe_help, "left-fringe-help"); DEFSYM (Qline_spacing, "line-spacing"); DEFSYM (Qmenu_bar_lines, "menu-bar-lines"); DEFSYM (Qtab_bar_lines, "tab-bar-lines"); @@ -6390,6 +6393,7 @@ syms_of_frame (void) DEFSYM (Qname, "name"); DEFSYM (Qright_divider_width, "right-divider-width"); DEFSYM (Qright_fringe, "right-fringe"); + DEFSYM (Qright_fringe_help, "right-fringe-help"); DEFSYM (Qscreen_gamma, "screen-gamma"); DEFSYM (Qscroll_bar_background, "scroll-bar-background"); DEFSYM (Qscroll_bar_foreground, "scroll-bar-foreground"); diff --git a/src/frame.h b/src/frame.h index e03362361a7..63bcce259af 100644 --- a/src/frame.h +++ b/src/frame.h @@ -126,6 +126,10 @@ struct text_conversion_state /* Overlay representing the composing region. */ Lisp_Object compose_region_overlay; + /* Cons of (START END . WINDOW) holding the field to which text + conversion should be confined, or nil if no such field exists. */ + Lisp_Object field; + /* The number of ongoing ``batch edits'' that are causing point reporting to be delayed. */ int batch_edit_count; diff --git a/src/ftfont.c b/src/ftfont.c index 0d10de5408f..2e37b62ea35 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -2030,7 +2030,6 @@ ftfont_drive_otf (MFLTFont *font, int i, j, gidx; OTF_Glyph *otfg; char script[5], *langsys = NULL; - char *gsub_features = NULL, *gpos_features = NULL; OTF_Feature *features; if (len == 0) @@ -2044,6 +2043,7 @@ ftfont_drive_otf (MFLTFont *font, OTF_tag_name (spec->langsys, langsys); } + char *gfeatures[2] = {NULL, NULL}; USE_SAFE_ALLOCA; for (i = 0; i < 2; i++) { @@ -2052,11 +2052,10 @@ ftfont_drive_otf (MFLTFont *font, if (spec->features[i] && spec->features[i][1] != 0xFFFFFFFF) { for (j = 0; spec->features[i][j]; j++); + if (j == 0) + continue; SAFE_NALLOCA (p, 6, j); - if (i == 0) - gsub_features = p; - else - gpos_features = p; + gfeatures[i] = p; for (j = 0; spec->features[i][j]; j++) { if (spec->features[i][j] == 0xFFFFFFFF) @@ -2071,6 +2070,7 @@ ftfont_drive_otf (MFLTFont *font, *--p = '\0'; } } + char *gsub_features = gfeatures[0], *gpos_features = gfeatures[1]; setup_otf_gstring (len); for (i = 0; i < len; i++) diff --git a/src/gnutls.c b/src/gnutls.c index 54b7eb4c90e..3ff7f21d5a5 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1142,7 +1142,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) int version = gnutls_x509_crt_get_version (cert); check_memory_full (version); if (version >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":version"), + res = nconc2 (res, list2 (QCversion, make_fixnum (version))); } @@ -1156,7 +1156,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_serial (cert, serial, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":serial-number"), + res = nconc2 (res, list2 (QCserial_number, gnutls_hex_string (serial, buf_size, ""))); xfree (serial); } @@ -1171,7 +1171,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_issuer_dn (cert, dn, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":issuer"), + res = nconc2 (res, list2 (QCissuer, make_string (dn, buf_size))); xfree (dn); } @@ -1185,11 +1185,11 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) time_t tim = gnutls_x509_crt_get_activation_time (cert); if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t)) - res = nconc2 (res, list2 (intern (":valid-from"), build_string (buf))); + res = nconc2 (res, list2 (QCvalid_from, build_string (buf))); tim = gnutls_x509_crt_get_expiration_time (cert); if (gmtime_r (&tim, &t) && strftime (buf, sizeof buf, "%Y-%m-%d", &t)) - res = nconc2 (res, list2 (intern (":valid-to"), build_string (buf))); + res = nconc2 (res, list2 (QCvalid_to, build_string (buf))); } /* Subject. */ @@ -1202,7 +1202,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_dn (cert, dn, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":subject"), + res = nconc2 (res, list2 (QCsubject, make_string (dn, buf_size))); xfree (dn); } @@ -1217,12 +1217,12 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) { const char *name = gnutls_pk_algorithm_get_name (err); if (name) - res = nconc2 (res, list2 (intern (":public-key-algorithm"), + res = nconc2 (res, list2 (QCpublic_key_algorithm, build_string (name))); name = gnutls_sec_param_get_name (gnutls_pk_bits_to_sec_param (err, bits)); - res = nconc2 (res, list2 (intern (":certificate-security-level"), + res = nconc2 (res, list2 (QCcertificate_security_level, build_string (name))); } } @@ -1237,7 +1237,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_issuer_unique_id (cert, buf, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":issuer-unique-id"), + res = nconc2 (res, list2 (QCissuer_unique_id, make_string (buf, buf_size))); xfree (buf); } @@ -1251,7 +1251,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_subject_unique_id (cert, buf, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":subject-unique-id"), + res = nconc2 (res, list2 (QCsubject_unique_id, make_string (buf, buf_size))); xfree (buf); } @@ -1263,7 +1263,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) { const char *name = gnutls_sign_get_name (err); if (name) - res = nconc2 (res, list2 (intern (":signature-algorithm"), + res = nconc2 (res, list2 (QCsignature_algorithm, build_string (name))); } @@ -1277,7 +1277,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_key_id (cert, 0, buf, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":public-key-id"), + res = nconc2 (res, list2 (QCpublic_key_id, gnutls_hex_string (buf, buf_size, "sha1:"))); xfree (buf); } @@ -1293,7 +1293,7 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) err = gnutls_x509_crt_get_key_id (cert, GNUTLS_KEYID_USE_SHA256, buf, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":public-key-id-sha256"), + res = nconc2 (res, list2 (QCpublic_key_id_sha256, gnutls_hex_string (buf, buf_size, "sha256:"))); xfree (buf); } @@ -1311,13 +1311,13 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert) buf, &buf_size); check_memory_full (err); if (err >= GNUTLS_E_SUCCESS) - res = nconc2 (res, list2 (intern (":certificate-id"), + res = nconc2 (res, list2 (QCcertificate_id, gnutls_hex_string (buf, buf_size, "sha1:"))); xfree (buf); } /* PEM */ - res = nconc2 (res, list2 (intern (":pem"), + res = nconc2 (res, list2 (QCpem, emacs_gnutls_certificate_export_pem(cert))); return res; @@ -1329,55 +1329,55 @@ DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_descri { CHECK_SYMBOL (status_symbol); - if (EQ (status_symbol, intern (":invalid"))) + if (EQ (status_symbol, QCinvalid)) return build_string ("certificate could not be verified"); - if (EQ (status_symbol, intern (":revoked"))) + if (EQ (status_symbol, QCrevoked)) return build_string ("certificate was revoked (CRL)"); - if (EQ (status_symbol, intern (":self-signed"))) + if (EQ (status_symbol, QCself_signed)) return build_string ("certificate signer was not found (self-signed)"); - if (EQ (status_symbol, intern (":unknown-ca"))) + if (EQ (status_symbol, QCunknown_ca)) return build_string ("the certificate was signed by an unknown " "and therefore untrusted authority"); - if (EQ (status_symbol, intern (":not-ca"))) + if (EQ (status_symbol, QCnot_ca)) return build_string ("certificate signer is not a CA"); - if (EQ (status_symbol, intern (":insecure"))) + if (EQ (status_symbol, QCinsecure)) return build_string ("certificate was signed with an insecure algorithm"); - if (EQ (status_symbol, intern (":not-activated"))) + if (EQ (status_symbol, QCnot_activated)) return build_string ("certificate is not yet activated"); - if (EQ (status_symbol, intern (":expired"))) + if (EQ (status_symbol, QCexpired)) return build_string ("certificate has expired"); - if (EQ (status_symbol, intern (":no-host-match"))) + if (EQ (status_symbol, QCno_host_match)) return build_string ("certificate host does not match hostname"); - if (EQ (status_symbol, intern (":signature-failure"))) + if (EQ (status_symbol, QCsignature_failure)) return build_string ("certificate signature could not be verified"); - if (EQ (status_symbol, intern (":revocation-data-superseded"))) + if (EQ (status_symbol, QCrevocation_data_superseded)) return build_string ("certificate revocation data are old and have been " "superseded"); - if (EQ (status_symbol, intern (":revocation-data-issued-in-future"))) + if (EQ (status_symbol, QCrevocation_data_issued_in_future)) return build_string ("certificate revocation data have a future issue date"); - if (EQ (status_symbol, intern (":signer-constraints-failure"))) + if (EQ (status_symbol, QCsigner_constraints_failure)) return build_string ("certificate signer constraints were violated"); - if (EQ (status_symbol, intern (":purpose-mismatch"))) + if (EQ (status_symbol, QCpurpose_mismatch)) return build_string ("certificate does not match the intended purpose"); - if (EQ (status_symbol, intern (":missing-ocsp-status"))) + if (EQ (status_symbol, QCmissing_ocsp_status)) return build_string ("certificate requires the server to send a OCSP " "certificate status, but no status was received"); - if (EQ (status_symbol, intern (":invalid-ocsp-status"))) + if (EQ (status_symbol, QCinvalid_ocsp_status)) return build_string ("the received OCSP certificate status is invalid"); return Qnil; @@ -1411,50 +1411,50 @@ returned as the :certificate entry. */) verification = XPROCESS (proc)->gnutls_peer_verification; if (verification & GNUTLS_CERT_INVALID) - warnings = Fcons (intern (":invalid"), warnings); + warnings = Fcons (QCinvalid, warnings); if (verification & GNUTLS_CERT_REVOKED) - warnings = Fcons (intern (":revoked"), warnings); + warnings = Fcons (QCrevoked, warnings); if (verification & GNUTLS_CERT_SIGNER_NOT_FOUND) - warnings = Fcons (intern (":unknown-ca"), warnings); + warnings = Fcons (QCunknown_ca, warnings); if (verification & GNUTLS_CERT_SIGNER_NOT_CA) - warnings = Fcons (intern (":not-ca"), warnings); + warnings = Fcons (QCnot_ca, warnings); if (verification & GNUTLS_CERT_INSECURE_ALGORITHM) - warnings = Fcons (intern (":insecure"), warnings); + warnings = Fcons (QCinsecure, warnings); if (verification & GNUTLS_CERT_NOT_ACTIVATED) - warnings = Fcons (intern (":not-activated"), warnings); + warnings = Fcons (QCnot_activated, warnings); if (verification & GNUTLS_CERT_EXPIRED) - warnings = Fcons (intern (":expired"), warnings); + warnings = Fcons (QCexpired, warnings); # if GNUTLS_VERSION_NUMBER >= 0x030100 if (verification & GNUTLS_CERT_SIGNATURE_FAILURE) - warnings = Fcons (intern (":signature-failure"), warnings); + warnings = Fcons (QCsignature_failure, warnings); # if GNUTLS_VERSION_NUMBER >= 0x030114 if (verification & GNUTLS_CERT_REVOCATION_DATA_SUPERSEDED) - warnings = Fcons (intern (":revocation-data-superseded"), warnings); + warnings = Fcons (QCrevocation_data_superseded, warnings); if (verification & GNUTLS_CERT_REVOCATION_DATA_ISSUED_IN_FUTURE) - warnings = Fcons (intern (":revocation-data-issued-in-future"), warnings); + warnings = Fcons (QCrevocation_data_issued_in_future, warnings); if (verification & GNUTLS_CERT_SIGNER_CONSTRAINTS_FAILURE) - warnings = Fcons (intern (":signer-constraints-failure"), warnings); + warnings = Fcons (QCsigner_constraints_failure, warnings); # if GNUTLS_VERSION_NUMBER >= 0x030400 if (verification & GNUTLS_CERT_PURPOSE_MISMATCH) - warnings = Fcons (intern (":purpose-mismatch"), warnings); + warnings = Fcons (QCpurpose_mismatch, warnings); # if GNUTLS_VERSION_NUMBER >= 0x030501 if (verification & GNUTLS_CERT_MISSING_OCSP_STATUS) - warnings = Fcons (intern (":missing-ocsp-status"), warnings); + warnings = Fcons (QCmissing_ocsp_status, warnings); if (verification & GNUTLS_CERT_INVALID_OCSP_STATUS) - warnings = Fcons (intern (":invalid-ocsp-status"), warnings); + warnings = Fcons (QCinvalid_ocsp_status, warnings); # endif # endif # endif @@ -1462,17 +1462,17 @@ returned as the :certificate entry. */) if (XPROCESS (proc)->gnutls_extra_peer_verification & CERTIFICATE_NOT_MATCHING) - warnings = Fcons (intern (":no-host-match"), warnings); + warnings = Fcons (QCno_host_match, warnings); /* This could get called in the INIT stage, when the certificate is not yet set. */ if (XPROCESS (proc)->gnutls_certificates != NULL && gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificates[0], XPROCESS (proc)->gnutls_certificates[0])) - warnings = Fcons (intern (":self-signed"), warnings); + warnings = Fcons (QCself_signed, warnings); if (!NILP (warnings)) - result = list2 (intern (":warnings"), warnings); + result = list2 (QCwarnings, warnings); /* This could get called in the INIT stage, when the certificate is not yet set. */ @@ -1485,11 +1485,11 @@ returned as the :certificate entry. */) certs = nconc2 (certs, list1 (emacs_gnutls_certificate_details (XPROCESS (proc)->gnutls_certificates[i]))); - result = nconc2 (result, list2 (intern (":certificates"), certs)); + result = nconc2 (result, list2 (QCcertificates, certs)); /* Return the host certificate in its own element for compatibility reasons. */ - result = nconc2 (result, list2 (intern (":certificate"), Fcar (certs))); + result = nconc2 (result, list2 (QCcertificate, Fcar (certs))); } state = XPROCESS (proc)->gnutls_state; @@ -1499,38 +1499,38 @@ returned as the :certificate entry. */) int bits = gnutls_dh_get_prime_bits (state); check_memory_full (bits); if (bits > 0) - result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"), + result = nconc2 (result, list2 (QCdiffie_hellman_prime_bits, make_fixnum (bits))); } /* Key exchange. */ result = nconc2 - (result, list2 (intern (":key-exchange"), + (result, list2 (QCkey_exchange, build_string (gnutls_kx_get_name (gnutls_kx_get (state))))); /* Protocol name. */ gnutls_protocol_t proto = gnutls_protocol_get_version (state); result = nconc2 - (result, list2 (intern (":protocol"), + (result, list2 (QCprotocol, build_string (gnutls_protocol_get_name (proto)))); /* Cipher name. */ result = nconc2 - (result, list2 (intern (":cipher"), + (result, list2 (QCcipher, build_string (gnutls_cipher_get_name (gnutls_cipher_get (state))))); /* MAC name. */ result = nconc2 - (result, list2 (intern (":mac"), + (result, list2 (QCmac, build_string (gnutls_mac_get_name (gnutls_mac_get (state))))); /* Compression name. */ # ifdef HAVE_GNUTLS_COMPRESSION_GET result = nconc2 - (result, list2 (intern (":compression"), + (result, list2 (QCcompression, build_string (gnutls_compression_get_name (gnutls_compression_get (state))))); # endif @@ -1538,14 +1538,14 @@ returned as the :certificate entry. */) /* Encrypt-then-MAC. */ # ifdef HAVE_GNUTLS_ETM_STATUS result = nconc2 - (result, list2 (intern (":encrypt-then-mac"), + (result, list2 (QCencrypt_then_mac, gnutls_session_etm_status (state) ? Qt : Qnil)); # endif /* Renegotiation Indication */ if (proto <= GNUTLS_TLS1_2) result = nconc2 - (result, list2 (intern (":safe-renegotiation"), + (result, list2 (QCsafe_renegotiation, gnutls_safe_renegotiation_status (state) ? Qt : Qnil)); return result; @@ -1701,7 +1701,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) p->gnutls_peer_verification = peer_verification; - warnings = plist_get (Fgnutls_peer_status (proc), intern (":warnings")); + warnings = plist_get (Fgnutls_peer_status (proc), QCwarnings); if (!NILP (warnings)) { for (Lisp_Object tail = warnings; CONSP (tail); tail = XCDR (tail)) @@ -2953,22 +2953,22 @@ Any GnuTLS extension with ID up to 100 return Qnil; # endif /* WINDOWSNT */ - capabilities = Fcons (intern("gnutls"), capabilities); + capabilities = Fcons (Qgnutls, capabilities); # ifdef HAVE_GNUTLS_EXT__DUMBFW - capabilities = Fcons (intern("ClientHello Padding"), capabilities); + capabilities = Fcons (QClientHello_Padding, capabilities); # endif # ifdef HAVE_GNUTLS3 - capabilities = Fcons (intern("gnutls3"), capabilities); - capabilities = Fcons (intern("digests"), capabilities); - capabilities = Fcons (intern("ciphers"), capabilities); + capabilities = Fcons (Qgnutls3, capabilities); + capabilities = Fcons (Qdigests, capabilities); + capabilities = Fcons (Qciphers, capabilities); # ifdef HAVE_GNUTLS_AEAD - capabilities = Fcons (intern("AEAD-ciphers"), capabilities); + capabilities = Fcons (QAEAD_ciphers, capabilities); # endif - capabilities = Fcons (intern("macs"), capabilities); + capabilities = Fcons (Qmacs, capabilities); # ifdef HAVE_GNUTLS_EXT_GET_NAME for (unsigned int ext=0; ext < 100; ext++) @@ -3119,4 +3119,55 @@ are as per the GnuTLS logging conventions. */); #endif /* HAVE_GNUTLS */ defsubr (&Sgnutls_available_p); + + DEFSYM (QAEAD_ciphers, "AEAD-ciphers"); + DEFSYM (QCcertificate, ":certificate"); + DEFSYM (QCcertificate_id, ":certificate-id"); + DEFSYM (QCcertificate_security_level, ":certificate-security-level"); + DEFSYM (QCcertificates, ":certificates"); + DEFSYM (QCcipher, ":cipher"); + DEFSYM (QCcompression, ":compression"); + DEFSYM (QCdiffie_hellman_prime_bits, ":diffie-hellman-prime-bits"); + DEFSYM (QCencrypt_then_mac, ":encrypt-then-mac"); + DEFSYM (QCexpired, ":expired"); + DEFSYM (QCinsecure, ":insecure"); + DEFSYM (QCinvalid, ":invalid"); + DEFSYM (QCinvalid_ocsp_status, ":invalid-ocsp-status"); + DEFSYM (QCissuer, ":issuer"); + DEFSYM (QCissuer_unique_id, ":issuer-unique-id"); + DEFSYM (QCkey_exchange, ":key-exchange"); + DEFSYM (QClientHello_Padding, "ClientHello Padding"); + DEFSYM (QCmac, ":mac"); + DEFSYM (QCmissing_ocsp_status, ":missing-ocsp-status"); + DEFSYM (QCno_host_match, ":no-host-match"); + DEFSYM (QCnot_activated, ":not-activated"); + DEFSYM (QCnot_ca, ":not-ca"); + DEFSYM (QCpem, ":pem"); + DEFSYM (QCprotocol, ":protocol"); + DEFSYM (QCpublic_key_algorithm, ":public-key-algorithm"); + DEFSYM (QCpublic_key_id, ":public-key-id"); + DEFSYM (QCpublic_key_id_sha256, ":public-key-id-sha256"); + DEFSYM (QCpurpose_mismatch, ":purpose-mismatch"); + DEFSYM (QCrevocation_data_issued_in_future, + ":revocation-data-issued-in-future"); + DEFSYM (QCrevocation_data_superseded, ":revocation-data-superseded"); + DEFSYM (QCrevoked, ":revoked"); + DEFSYM (QCsafe_renegotiation, ":safe-renegotiation"); + DEFSYM (QCself_signed, ":self-signed"); + DEFSYM (QCserial_number, ":serial-number"); + DEFSYM (QCsignature_algorithm, ":signature-algorithm"); + DEFSYM (QCsignature_failure, ":signature-failure"); + DEFSYM (QCsigner_constraints_failure, ":signer-constraints-failure"); + DEFSYM (QCsubject, ":subject"); + DEFSYM (QCsubject_unique_id, ":subject-unique-id"); + DEFSYM (QCunknown_ca, ":unknown-ca"); + DEFSYM (QCvalid_from, ":valid-from"); + DEFSYM (QCvalid_to, ":valid-to"); + DEFSYM (QCversion, ":version"); + DEFSYM (QCwarnings, ":warnings"); + DEFSYM (Qciphers, "ciphers"); + DEFSYM (Qdigests, "digests"); + DEFSYM (Qgnutls, "gnutls"); + DEFSYM (Qgnutls3, "gnutls3"); + DEFSYM (Qmacs, "macs"); } diff --git a/src/gtkutil.c b/src/gtkutil.c index c067f7b53ac..7de8eba0aa1 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -1471,8 +1471,7 @@ style_changed_cb (GObject *go, EVENT_INIT (event); event.kind = CONFIG_CHANGED_EVENT; event.frame_or_window = build_string (display_name); - /* Theme doesn't change often, so intern is called seldom. */ - event.arg = intern ("theme-name"); + event.arg = Qtheme_name; kbd_buffer_store_event (&event); update_theme_scrollbar_width (); @@ -5506,8 +5505,8 @@ find_rtl_image (struct frame *f, Lisp_Object image, Lisp_Object rtl) Lisp_Object rtl_image = PROP (TOOL_BAR_ITEM_IMAGES); if (!NILP (file = file_for_image (rtl_image))) { - file = call1 (intern ("file-name-sans-extension"), - Ffile_name_nondirectory (file)); + file = call1 (Qfile_name_sans_extension, + Ffile_name_nondirectory (file)); if (! NILP (Fequal (file, rtl_name))) { image = rtl_image; diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 1b9c5acdf14..08e7f29685a 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1063,6 +1063,13 @@ public: uint32_t mods = modifiers (); + if (haiku_should_pass_control_tab_to_system () + && (mods & B_CONTROL_KEY) && key == 38) + { + BWindow::DispatchMessage (msg, handler); + return; + } + if (mods & B_SHIFT_KEY) rq.modifiers |= HAIKU_MODIFIER_SHIFT; diff --git a/src/haiku_support.h b/src/haiku_support.h index e9ac7005d75..6c0e5fa7acd 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -691,6 +691,8 @@ extern int be_get_display_color_cells (void); extern bool be_is_display_grayscale (void); extern void be_warp_pointer (int, int); +extern bool haiku_should_pass_control_tab_to_system (void); + extern void EmacsView_set_up_double_buffering (void *); extern void EmacsView_disable_double_buffering (void *); extern void EmacsView_flip_and_blit (void *); diff --git a/src/haikufns.c b/src/haikufns.c index 173c1e369df..870b6f58f02 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -2194,6 +2194,12 @@ haiku_set_use_frame_synchronization (struct frame *f, Lisp_Object arg, be_set_use_frame_synchronization (FRAME_HAIKU_VIEW (f), !NILP (arg)); } +bool +haiku_should_pass_control_tab_to_system (void) +{ + return haiku_pass_control_tab_to_system; +} + DEFUN ("haiku-set-mouse-absolute-pixel-position", @@ -3302,6 +3308,14 @@ syms_of_haikufns (void) doc: /* SKIP: real doc in xfns.c. */); Vx_sensitive_text_pointer_shape = Qnil; + DEFVAR_BOOL ("haiku-pass-control-tab-to-system", + haiku_pass_control_tab_to_system, + doc: /* Whether or not to pass C-TAB to the system. +Setting this variable will cause Emacs to pass C-TAB to the system +(allowing window switching on the Haiku operating system), rather than +intercepting it. */); + haiku_pass_control_tab_to_system = true; + DEFVAR_LISP ("haiku-allowed-ui-colors", Vhaiku_allowed_ui_colors, doc: /* Vector of UI colors that Emacs can look up from the system. If this is set up incorrectly, Emacs can crash when encountering an diff --git a/src/haikuterm.c b/src/haikuterm.c index 135f99dbdcb..c194a348df3 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -804,6 +804,86 @@ haiku_draw_underwave (struct glyph_string *s, int width, int x) BView_EndClip (view); } +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto F + at a vertical offset of OFFSET from the position of the glyph string + S, with each segment SEGMENT pixels in length. */ + +static void +haiku_draw_dash (struct frame *f, struct glyph_string *s, int width, + int segment, int offset, int thickness) +{ + int y_center, which, length, x, doffset; + void *view; + + /* Configure the thickness of the view's strokes. */ + view = FRAME_HAIKU_VIEW (s->f); + BView_SetPenSize (view, thickness); + + /* Offset the origin of the line by half the line width. */ + y_center = s->ybase + offset + thickness / 2; + + /* Remove redundant portions of OFFSET. */ + doffset = s->x % (segment * 2); + + /* Set which to the phase of the first dash that ought to be drawn and + length to its length. */ + which = doffset < segment; + length = segment - (s->x % segment); + + /* Begin drawing this dash. */ + for (x = s->x; x < s->x + width; x += length, length = segment) + { + if (which) + BView_StrokeLine (view, x, y_center, + min (x + length - 1, + s->x + width - 1), + y_center); + + which = !which; + } +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, S->WIDTH in length, and THICKNESS in + height. */ + +static void +haiku_fill_underline (struct frame *f, struct glyph_string *s, + enum face_underline_type style, int position, + int thickness) +{ + int segment; + void *view; + + segment = thickness * 3; + view = FRAME_HAIKU_VIEW (f); + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + BView_FillRectangle (view, s->x, s->ybase + position, + s->width, thickness); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + haiku_draw_dash (f, s, s->width, segment, position, thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} + static void haiku_draw_text_decoration (struct glyph_string *s, struct face *face, int width, int x) @@ -827,15 +907,15 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, else BView_SetHighColor (view, face->foreground); - if (face->underline == FACE_UNDER_WAVE) + if (face->underline == FACE_UNDERLINE_WAVE) haiku_draw_underwave (s, width, x); - else if (face->underline == FACE_UNDER_LINE) + else if (face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -908,9 +988,20 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; s->underline_position = position; - y = s->ybase + position; - BView_FillRectangle (view, s->x, y, s->width, thickness); + haiku_fill_underline (s->f, s, s->face->underline, + position, thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + haiku_fill_underline (s->f, s, s->face->underline, + position, thickness); + } } } diff --git a/src/hbfont.c b/src/hbfont.c index 40bb44c7d04..37ed4132492 100644 --- a/src/hbfont.c +++ b/src/hbfont.c @@ -552,6 +552,8 @@ hbfont_shape (Lisp_Object lgstring, Lisp_Object direction) cluster_offset = to - from; } + eassume (0 <= from); + /* All the glyphs in a cluster have the same values of FROM and TO. */ LGLYPH_SET_FROM (lglyph, from); /* This heuristic is for when the Lisp shape-gstring function diff --git a/src/image.c b/src/image.c index 41d72964631..e93fc3183af 100644 --- a/src/image.c +++ b/src/image.c @@ -198,6 +198,9 @@ typedef android_pixmap Pixmap; #define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG (color) * 0x101) #define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG (color) * 0x101) +/* DPYINFO->n_planes is unsuitable for this file, because it accepts + values that may not be supported for pixmap creation. */ +#define n_planes n_image_planes #endif static void image_disable_image (struct frame *, struct image *); @@ -419,7 +422,7 @@ x_bitmap_stipple (struct frame *f, Pixmap pixmap) #endif /* USE_CAIRO */ #endif -#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) || defined (HAVE_ANDROID) ptrdiff_t image_bitmap_pixmap (struct frame *f, ptrdiff_t id) { @@ -763,7 +766,6 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file) ptrdiff_t id, size; int fd, width, height, rc; char *contents, *data; - void *bitmap; if (!STRINGP (image_find_image_fd (file, &fd))) return -1; @@ -954,10 +956,17 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file) } } - /* Search bitmap-file-path for the file, if appropriate. */ - if (openp (Vx_bitmap_file_path, file, Qnil, &found, - make_fixnum (R_OK), false, false, NULL) - < 0) + /* Search bitmap-file-path for the file, if appropriate. If no file + extension or directory is specified and no file by this name + exists, append the extension ".xbm" and retry. */ + if ((openp (Vx_bitmap_file_path, file, Qnil, &found, + make_fixnum (R_OK), false, false, NULL) < 0) + && (NILP (Fequal (Ffile_name_nondirectory (file), file)) + || strrchr (SSDATA (file), '.') + || (openp (Vx_bitmap_file_path, + CALLN (Fconcat, file, build_string (".xbm")), + Qnil, &found, make_fixnum (R_OK), false, false, + NULL) < 0))) return -1; if (!STRINGP (image_find_image_fd (file, &fd)) @@ -1699,14 +1708,26 @@ free_image (struct frame *f, struct image *img) c->images[img->id] = NULL; #if !defined USE_CAIRO && defined HAVE_XRENDER - if (img->picture) - XRenderFreePicture (FRAME_X_DISPLAY (f), img->picture); - if (img->mask_picture) - XRenderFreePicture (FRAME_X_DISPLAY (f), img->mask_picture); -#endif + /* FRAME_X_DISPLAY (f) could be NULL if this is being called from + the display IO error handler.*/ + + if (FRAME_X_DISPLAY (f)) + { + if (img->picture) + XRenderFreePicture (FRAME_X_DISPLAY (f), + img->picture); + if (img->mask_picture) + XRenderFreePicture (FRAME_X_DISPLAY (f), + img->mask_picture); + } +#endif /* !USE_CAIRO && HAVE_XRENDER */ + +#ifdef HAVE_X_WINDOWS + if (FRAME_X_DISPLAY (f)) +#endif /* HAVE_X_WINDOWS */ + /* Free resources, then free IMG. */ + img->type->free_img (f, img); - /* Free resources, then free IMG. */ - img->type->free_img (f, img); xfree (img->face_font_family); xfree (img); } @@ -2558,9 +2579,20 @@ image_get_dimension (struct image *img, Lisp_Object symbol) if (FIXNATP (value)) return min (XFIXNAT (value), INT_MAX); - if (CONSP (value) && NUMBERP (CAR (value)) && EQ (Qem, CDR (value))) - return scale_image_size (img->face_font_size, 1, XFLOATINT (CAR (value))); + if (CONSP (value) && NUMBERP (CAR (value))) + { + Lisp_Object dim = CDR (value); + if (EQ (Qem, dim)) + return scale_image_size (img->face_font_size, + 1, XFLOATINT (CAR (value))); + if (EQ (Qch, dim)) + return scale_image_size (img->face_font_height, + 1, XFLOATINT (CAR (value))); + if (EQ (Qcw, dim)) + return scale_image_size (img->face_font_width, + 1, XFLOATINT (CAR (value))); + } return -1; } @@ -3384,6 +3416,8 @@ lookup_image (struct frame *f, Lisp_Object spec, int face_id) img->face_foreground = foreground; img->face_background = background; img->face_font_size = font_size; + img->face_font_height = face->font->height; + img->face_font_width = face->font->average_width; img->face_font_family = xmalloc (strlen (font_family) + 1); strcpy (img->face_font_family, font_family); img->load_failed_p = ! img->type->load_img (f, img); @@ -6202,6 +6236,8 @@ xpm_load_image (struct frame *f, expect (','); XSETFRAME (frame, f); + +#ifndef HAVE_ANDROID if (!NILP (Fxw_display_color_p (frame))) best_key = XPM_COLOR_KEY_C; else if (!NILP (Fx_display_grayscale_p (frame))) @@ -6209,6 +6245,14 @@ xpm_load_image (struct frame *f, ? XPM_COLOR_KEY_G : XPM_COLOR_KEY_G4); else best_key = XPM_COLOR_KEY_M; +#else /* HAVE_ANDROID */ + /* The color-loading loop has not been taught to progressively settle + for less optimal color keys if no colors are defined for best_key, + and since libXpm is not available on Android, there is no better + option than delegating the task of mapping whatever color values + are provided to B/W or grayscale to the display driver. */ + best_key = XPM_COLOR_KEY_C; +#endif /* !HAVE_ANDROID */ color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); if (chars_per_pixel == 1) @@ -10677,14 +10721,14 @@ imagemagick_error (MagickWand *wand) static char * imagemagick_filename_hint (Lisp_Object spec, char hint_buffer[MaxTextExtent]) { - Lisp_Object symbol = intern ("image-format-suffixes"); + Lisp_Object symbol = Qimage_format_suffixes; Lisp_Object val = find_symbol_value (symbol); Lisp_Object format; if (! CONSP (val)) return NULL; - format = image_spec_value (spec, intern (":format"), NULL); + format = image_spec_value (spec, QCformat, NULL); val = Fcar_safe (Fcdr_safe (Fassq (format, val))); if (! STRINGP (val)) return NULL; @@ -12433,7 +12477,7 @@ gs_load (struct frame *f, struct image *img) XSETFRAME (frame, f); loader = image_spec_value (img->spec, QCloader, NULL); if (NILP (loader)) - loader = intern ("gs-load-image"); + loader = Qgs_load_image; img->lisp_data = call6 (loader, frame, img->spec, make_fixnum (img->width), @@ -12794,6 +12838,8 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (QCmax_height, ":max-height"); DEFSYM (Qem, "em"); + DEFSYM (Qch, "ch"); + DEFSYM (Qcw, "cw"); #ifdef HAVE_NATIVE_TRANSFORMS DEFSYM (Qscale, "scale"); @@ -12807,6 +12853,7 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (QCloader, ":loader"); DEFSYM (QCpt_width, ":pt-width"); DEFSYM (QCpt_height, ":pt-height"); + DEFSYM (Qgs_load_image, "gs-load-image"); #endif /* HAVE_GHOSTSCRIPT */ #ifdef HAVE_NTGUI @@ -12986,5 +13033,8 @@ The options are: */); /* MagickExportImagePixels is in 6.4.6-9, but not 6.4.4-10. */ imagemagick_render_type = 0; -#endif + + DEFSYM (Qimage_format_suffixes, "image-format-suffixes"); + DEFSYM (QCformat, ":format"); +#endif /* HAVE_IMAGEMAGICK */ } diff --git a/src/intervals.c b/src/intervals.c index 2ab19c2cc56..c7a1f81e4ee 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -2388,17 +2388,18 @@ set_intervals_multibyte_1 (INTERVAL i, bool multi_flag, to this interval. */ if (LEFT_TOTAL_LENGTH (i) + RIGHT_TOTAL_LENGTH (i) >= TOTAL_LENGTH (i)) { - if ((i)->left) + if (i->left) { set_interval_plist (i, i->left->plist); - (i)->left->total_length = 0; + i->left->total_length = 0; delete_interval ((i)->left); } else { + eassume (i->right); set_interval_plist (i, i->right->plist); - (i)->right->total_length = 0; - delete_interval ((i)->right); + i->right->total_length = 0; + delete_interval (i->right); } } } diff --git a/src/intervals.h b/src/intervals.h index 610c803cc77..5718874543a 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -204,14 +204,21 @@ set_interval_plist (INTERVAL i, Lisp_Object plist) #define INTERVAL_VISIBLE_P(i) \ (i && NILP (textget ((i)->plist, Qinvisible))) -/* Is this interval writable? Replace later with cache access. */ -#define INTERVAL_WRITABLE_P(i) \ - (NILP (textget ((i)->plist, Qread_only)) \ - || !NILP (textget ((i)->plist, Qinhibit_read_only)) \ - || ((CONSP (Vinhibit_read_only) \ - ? !NILP (Fmemq (textget ((i)->plist, Qread_only), \ - Vinhibit_read_only)) \ - : !NILP (Vinhibit_read_only)))) +/* Is this interval writable by virtue of not being marked read-only + by the 'read-only' property (passed via RO), or due to the general + value of Vinhibit_read_only? Replace later with cache access. */ +#define INTERVAL_GENERALLY_WRITABLE_P(i, ro) \ + (NILP (ro) || (!NILP (Vinhibit_read_only) \ + && !CONSP (Vinhibit_read_only))) + +/* Is this interval writable by virtue of its explicit + 'inhibit-read-only' property, or due to the presence of its + 'read-only' property (passed via RO) in Vinhibit_read_only list? */ +#define INTERVAL_EXPRESSLY_WRITABLE_P(i, ro) \ + (!NILP (textget ((i)->plist, Qinhibit_read_only)) \ + || (!NILP (ro) \ + && CONSP (Vinhibit_read_only) \ + && !NILP (Fmemq ((ro), Vinhibit_read_only)))) /* Macros to tell whether insertions before or after this interval should stick to it. Now we have Vtext_property_default_nonsticky, diff --git a/src/json.c b/src/json.c index afc48c59d5a..140c3625d4d 100644 --- a/src/json.c +++ b/src/json.c @@ -25,674 +25,658 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <stdlib.h> #include <math.h> -#include <jansson.h> - #include "lisp.h" #include "buffer.h" #include "coding.h" -#ifdef WINDOWSNT -# include <windows.h> -# include "w32common.h" -# include "w32.h" - -DEF_DLL_FN (void, json_set_alloc_funcs, - (json_malloc_t malloc_fn, json_free_t free_fn)); -DEF_DLL_FN (void, json_delete, (json_t *json)); -DEF_DLL_FN (json_t *, json_array, (void)); -DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value)); -DEF_DLL_FN (size_t, json_array_size, (const json_t *array)); -DEF_DLL_FN (json_t *, json_object, (void)); -DEF_DLL_FN (int, json_object_set_new, - (json_t *object, const char *key, json_t *value)); -DEF_DLL_FN (json_t *, json_null, (void)); -DEF_DLL_FN (json_t *, json_true, (void)); -DEF_DLL_FN (json_t *, json_false, (void)); -DEF_DLL_FN (json_t *, json_integer, (json_int_t value)); -DEF_DLL_FN (json_t *, json_real, (double value)); -DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len)); -DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags)); -DEF_DLL_FN (int, json_dump_callback, - (const json_t *json, json_dump_callback_t callback, void *data, - size_t flags)); -DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key)); - -/* This is called by json_decref, which is an inline function. */ -void json_delete(json_t *json) -{ - fn_json_delete (json); +enum json_object_type + { + json_object_hashtable, + json_object_alist, + json_object_plist, + }; + +enum json_array_type + { + json_array_array, + json_array_list, + }; + +struct json_configuration +{ + enum json_object_type object_type; + enum json_array_type array_type; + Lisp_Object null_object; + Lisp_Object false_object; +}; + +static void +json_parse_args (ptrdiff_t nargs, Lisp_Object *args, + struct json_configuration *conf, + bool parse_object_types) +{ + if ((nargs % 2) != 0) + wrong_type_argument (Qplistp, Flist (nargs, args)); + + /* Start from the back so keyword values appearing first take + precedence. */ + for (ptrdiff_t i = nargs; i > 0; i -= 2) + { + Lisp_Object key = args[i - 2]; + Lisp_Object value = args[i - 1]; + if (parse_object_types && EQ (key, QCobject_type)) + { + if (EQ (value, Qhash_table)) + conf->object_type = json_object_hashtable; + else if (EQ (value, Qalist)) + conf->object_type = json_object_alist; + else if (EQ (value, Qplist)) + conf->object_type = json_object_plist; + else + wrong_choice (list3 (Qhash_table, Qalist, Qplist), value); + } + else if (parse_object_types && EQ (key, QCarray_type)) + { + if (EQ (value, Qarray)) + conf->array_type = json_array_array; + else if (EQ (value, Qlist)) + conf->array_type = json_array_list; + else + wrong_choice (list2 (Qarray, Qlist), value); + } + else if (EQ (key, QCnull_object)) + conf->null_object = value; + else if (EQ (key, QCfalse_object)) + conf->false_object = value; + else if (parse_object_types) + wrong_choice (list4 (QCobject_type, + QCarray_type, + QCnull_object, + QCfalse_object), + value); + else + wrong_choice (list2 (QCnull_object, + QCfalse_object), + value); + } } -static bool json_initialized; +/* JSON encoding context. */ +typedef struct +{ + char *buf; + ptrdiff_t size; /* number of bytes in buf */ + ptrdiff_t capacity; /* allocated size of buf */ + ptrdiff_t chars_delta; /* size - {number of characters in buf} */ -static bool -init_json_functions (void) + int maxdepth; + struct symset_tbl *ss_table; /* table used by containing object */ + struct json_configuration conf; +} json_out_t; + +/* Set of symbols. */ +typedef struct { - HMODULE library = w32_delayed_load (Qjson); + ptrdiff_t count; /* symbols in table */ + int bits; /* log2(table size) */ + struct symset_tbl *table; /* heap-allocated table */ +} symset_t; - if (!library) - return false; +struct symset_tbl +{ + /* Table used by the containing object if any, so that we can free all + tables if an error occurs. */ + struct symset_tbl *up; + /* Table of symbols (2**bits elements), Qunbound where unused. */ + Lisp_Object entries[]; +}; - LOAD_DLL_FN (library, json_set_alloc_funcs); - LOAD_DLL_FN (library, json_delete); - LOAD_DLL_FN (library, json_array); - LOAD_DLL_FN (library, json_array_append_new); - LOAD_DLL_FN (library, json_array_size); - LOAD_DLL_FN (library, json_object); - LOAD_DLL_FN (library, json_object_set_new); - LOAD_DLL_FN (library, json_null); - LOAD_DLL_FN (library, json_true); - LOAD_DLL_FN (library, json_false); - LOAD_DLL_FN (library, json_integer); - LOAD_DLL_FN (library, json_real); - LOAD_DLL_FN (library, json_stringn); - LOAD_DLL_FN (library, json_dumps); - LOAD_DLL_FN (library, json_dump_callback); - LOAD_DLL_FN (library, json_object_get); - - init_json (); - - return true; +static inline ptrdiff_t +symset_size (int bits) +{ + return (ptrdiff_t) 1 << bits; } -#define json_set_alloc_funcs fn_json_set_alloc_funcs -#define json_array fn_json_array -#define json_array_append_new fn_json_array_append_new -#define json_array_size fn_json_array_size -#define json_object fn_json_object -#define json_object_set_new fn_json_object_set_new -#define json_null fn_json_null -#define json_true fn_json_true -#define json_false fn_json_false -#define json_integer fn_json_integer -#define json_real fn_json_real -#define json_stringn fn_json_stringn -#define json_dumps fn_json_dumps -#define json_dump_callback fn_json_dump_callback -#define json_object_get fn_json_object_get - -#endif /* WINDOWSNT */ - -/* We install a custom allocator so that we can avoid objects larger - than PTRDIFF_MAX. Such objects wouldn't play well with the rest of - Emacs's codebase, which generally uses ptrdiff_t for sizes and - indices. The other functions in this file also generally assume - that size_t values never exceed PTRDIFF_MAX. - - In addition, we need to use a custom allocator because on - MS-Windows we replace malloc/free with our own functions, see - w32heap.c, so we must force the library to use our allocator, or - else we won't be able to free storage allocated by the library. */ - -static void * -json_malloc (size_t size) -{ - if (size > PTRDIFF_MAX) - { - errno = ENOMEM; - return NULL; - } - return malloc (size); +static struct symset_tbl * +make_symset_table (int bits, struct symset_tbl *up) +{ + int maxbits = min (SIZE_WIDTH - 2 - (word_size < 8 ? 2 : 3), 32); + if (bits > maxbits) + memory_full (PTRDIFF_MAX); /* Will never happen in practice. */ + struct symset_tbl *st = xmalloc (sizeof *st + (sizeof *st->entries << bits)); + st->up = up; + ptrdiff_t size = symset_size (bits); + for (ptrdiff_t i = 0; i < size; i++) + st->entries[i] = Qunbound; + return st; +} + +/* Create a new symset to use for a new object. */ +static symset_t +push_symset (json_out_t *jo) +{ + int bits = 4; + struct symset_tbl *tbl = make_symset_table (bits, jo->ss_table); + jo->ss_table = tbl; + return (symset_t){ .count = 0, .bits = bits, .table = tbl }; } +/* Destroy the current symset. */ static void -json_free (void *ptr) +pop_symset (json_out_t *jo, symset_t *ss) { - free (ptr); + jo->ss_table = ss->table->up; + xfree (ss->table); } -void -init_json (void) +/* Remove all heap-allocated symset tables, in case an error occurred. */ +static void +cleanup_symset_tables (struct symset_tbl *st) { - json_set_alloc_funcs (json_malloc, json_free); + while (st) + { + struct symset_tbl *up = st->up; + xfree (st); + st = up; + } } -/* Note that all callers of make_string_from_utf8 and build_string_from_utf8 - below either pass only value UTF-8 strings or use the functionf for - formatting error messages; in the latter case correctness isn't - critical. */ +static inline uint32_t +symset_hash (Lisp_Object sym, int bits) +{ + return knuth_hash (reduce_emacs_uint_to_hash_hash (XHASH (sym)), bits); +} -/* Return a unibyte string containing the sequence of UTF-8 encoding - units of the UTF-8 representation of STRING. If STRING does not - represent a sequence of Unicode scalar values, return a string with - unspecified contents. */ +/* Enlarge the table used by a symset. */ +static NO_INLINE void +symset_expand (symset_t *ss) +{ + struct symset_tbl *old_table = ss->table; + int oldbits = ss->bits; + ptrdiff_t oldsize = symset_size (oldbits); + int bits = oldbits + 1; + ss->bits = bits; + ss->table = make_symset_table (bits, old_table->up); + /* Move all entries from the old table to the new one. */ + ptrdiff_t mask = symset_size (bits) - 1; + struct symset_tbl *tbl = ss->table; + for (ptrdiff_t i = 0; i < oldsize; i++) + { + Lisp_Object sym = old_table->entries[i]; + if (!BASE_EQ (sym, Qunbound)) + { + ptrdiff_t j = symset_hash (sym, bits); + while (!BASE_EQ (tbl->entries[j], Qunbound)) + j = (j + 1) & mask; + tbl->entries[j] = sym; + } + } + xfree (old_table); +} -static Lisp_Object -json_encode (Lisp_Object string) +/* If sym is in ss, return false; otherwise add it and return true. + Comparison is done by strict identity. */ +static inline bool +symset_add (json_out_t *jo, symset_t *ss, Lisp_Object sym) { - /* FIXME: Raise an error if STRING is not a scalar value - sequence. */ - return encode_string_utf_8 (string, Qnil, false, Qt, Qt); + /* Make sure we don't fill more than half of the table. */ + if (ss->count >= (symset_size (ss->bits) >> 1)) + { + symset_expand (ss); + jo->ss_table = ss->table; + } + + struct symset_tbl *tbl = ss->table; + ptrdiff_t mask = symset_size (ss->bits) - 1; + for (ptrdiff_t i = symset_hash (sym, ss->bits); ; i = (i + 1) & mask) + { + Lisp_Object s = tbl->entries[i]; + if (BASE_EQ (s, sym)) + return false; /* Previous occurrence found. */ + if (BASE_EQ (s, Qunbound)) + { + /* Not in set, add it. */ + tbl->entries[i] = sym; + ss->count++; + return true; + } + } } -static AVOID -json_out_of_memory (void) +static NO_INLINE void +json_out_grow_buf (json_out_t *jo, ptrdiff_t bytes) { - xsignal0 (Qjson_out_of_memory); + ptrdiff_t need = jo->size + bytes; + ptrdiff_t new_size = max (jo->capacity, 512); + while (new_size < need) + new_size <<= 1; + jo->buf = xrealloc (jo->buf, new_size); + jo->capacity = new_size; } static void -json_release_object (void *object) +cleanup_json_out (void *arg) { - json_decref (object); + json_out_t *jo = arg; + xfree (jo->buf); + jo->buf = NULL; + cleanup_symset_tables (jo->ss_table); } -/* Signal an error if OBJECT is not a string, or if OBJECT contains - embedded null characters. */ - +/* Make room for `bytes` more bytes in buffer. */ static void -check_string_without_embedded_nulls (Lisp_Object object) +json_make_room (json_out_t *jo, ptrdiff_t bytes) { - CHECK_STRING (object); - CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, - Qstring_without_embedded_nulls_p, object); + if (bytes > jo->capacity - jo->size) + json_out_grow_buf (jo, bytes); } -/* Signal an error of type `json-out-of-memory' if OBJECT is - NULL. */ +#define JSON_OUT_STR(jo, str) (json_out_str (jo, str, sizeof (str) - 1)) -static json_t * -json_check (json_t *object) +/* Add `bytes` bytes from `str` to the buffer. */ +static void +json_out_str (json_out_t *jo, const char *str, size_t bytes) { - if (object == NULL) - json_out_of_memory (); - return object; + json_make_room (jo, bytes); + memcpy (jo->buf + jo->size, str, bytes); + jo->size += bytes; } -/* If STRING is not a valid UTF-8 string, signal an error of type - `wrong-type-argument'. STRING must be a unibyte string. */ - static void -json_check_utf8 (Lisp_Object string) +json_out_byte (json_out_t *jo, unsigned char c) { - CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string); + json_make_room (jo, 1); + jo->buf[jo->size++] = c; } -enum json_object_type { - json_object_hashtable, - json_object_alist, - json_object_plist -}; +static void +json_out_fixnum (json_out_t *jo, EMACS_INT x) +{ + char buf[INT_BUFSIZE_BOUND (EMACS_INT)]; + char *end = buf + sizeof buf; + char *p = fixnum_to_string (x, buf, end); + json_out_str (jo, p, end - p); +} -enum json_array_type { - json_array_array, - json_array_list -}; +static AVOID +string_not_unicode (Lisp_Object obj) +{ + /* FIXME: this is just for compatibility with existing tests, it's not + a very descriptive error. */ + wrong_type_argument (Qjson_value_p, obj); +} -struct json_configuration { - enum json_object_type object_type; - enum json_array_type array_type; - Lisp_Object null_object; - Lisp_Object false_object; +static const unsigned char json_plain_char[256] = { + /* 32 chars/line: 1 for printable ASCII + DEL except " and \, 0 elsewhere */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 00-1f */ + 1,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 20-3f */ + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1, /* 40-5f */ + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 60-7f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 80-9f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* a0-bf */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* c0-df */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* e0-ff */ }; -static json_t *lisp_to_json (Lisp_Object, - const struct json_configuration *conf); - -/* Convert a Lisp object to a nonscalar JSON object (array or object). */ - -static json_t * -lisp_to_json_nonscalar_1 (Lisp_Object lisp, - const struct json_configuration *conf) +static void +json_out_string (json_out_t *jo, Lisp_Object str, int skip) { - json_t *json; - specpdl_ref count; - - if (VECTORP (lisp)) - { - ptrdiff_t size = ASIZE (lisp); - json = json_check (json_array ()); - count = SPECPDL_INDEX (); - record_unwind_protect_ptr (json_release_object, json); - for (ptrdiff_t i = 0; i < size; ++i) - { - int status - = json_array_append_new (json, lisp_to_json (AREF (lisp, i), - conf)); - if (status == -1) - json_out_of_memory (); - } - eassert (json_array_size (json) == size); - } - else if (HASH_TABLE_P (lisp)) + /* FIXME: this code is slow, make faster! */ + + static const char hexchar[16] = "0123456789ABCDEF"; + ptrdiff_t len = SBYTES (str); + json_make_room (jo, len + 2); + json_out_byte (jo, '"'); + unsigned char *p = SDATA (str); + unsigned char *end = p + len; + p += skip; + while (p < end) { - struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); - json = json_check (json_object ()); - count = SPECPDL_INDEX (); - record_unwind_protect_ptr (json_release_object, json); - DOHASH (h, key, v) - { - CHECK_STRING (key); - Lisp_Object ekey = json_encode (key); - /* We can't specify the length, so the string must be - null-terminated. */ - check_string_without_embedded_nulls (ekey); - const char *key_str = SSDATA (ekey); - /* Reject duplicate keys. These are possible if the hash - table test is not `equal'. */ - if (json_object_get (json, key_str) != NULL) - wrong_type_argument (Qjson_value_p, lisp); - int status - = json_object_set_new (json, key_str, - lisp_to_json (v, conf)); - if (status == -1) + unsigned char c = *p; + if (json_plain_char[c]) + { + json_out_byte (jo, c); + p++; + } + else if (c > 0x7f) + { + if (STRING_MULTIBYTE (str)) { - /* A failure can be caused either by an invalid key or - by low memory. */ - json_check_utf8 (ekey); - json_out_of_memory (); + int n; + if (c <= 0xc1) + string_not_unicode (str); + if (c <= 0xdf) + n = 2; + else if (c <= 0xef) + { + int v = (((c & 0x0f) << 12) + + ((p[1] & 0x3f) << 6) + (p[2] & 0x3f)); + if (char_surrogate_p (v)) + string_not_unicode (str); + n = 3; + } + else if (c <= 0xf7) + { + int v = (((c & 0x07) << 18) + + ((p[1] & 0x3f) << 12) + + ((p[2] & 0x3f) << 6) + + (p[3] & 0x3f)); + if (v > MAX_UNICODE_CHAR) + string_not_unicode (str); + n = 4; + } + else + string_not_unicode (str); + json_out_str (jo, (const char *)p, n); + jo->chars_delta += n - 1; + p += n; } + else + string_not_unicode (str); + } + else + { + json_out_byte (jo, '\\'); + switch (c) + { + case '"': + case '\\': json_out_byte (jo, c); break; + case '\b': json_out_byte (jo, 'b'); break; + case '\t': json_out_byte (jo, 't'); break; + case '\n': json_out_byte (jo, 'n'); break; + case '\f': json_out_byte (jo, 'f'); break; + case '\r': json_out_byte (jo, 'r'); break; + default: + { + char hex[5] = { 'u', '0', '0', + hexchar[c >> 4], hexchar[c & 0xf] }; + json_out_str (jo, hex, 5); + break; + } + } + p++; } } - else if (NILP (lisp)) - return json_check (json_object ()); - else if (CONSP (lisp)) - { - Lisp_Object tail = lisp; - json = json_check (json_object ()); - count = SPECPDL_INDEX (); - record_unwind_protect_ptr (json_release_object, json); - bool is_plist = !CONSP (XCAR (tail)); - FOR_EACH_TAIL (tail) - { - const char *key_str; - Lisp_Object value; - Lisp_Object key_symbol; - if (is_plist) - { - key_symbol = XCAR (tail); - tail = XCDR (tail); - CHECK_CONS (tail); - value = XCAR (tail); - } - else - { - Lisp_Object pair = XCAR (tail); - CHECK_CONS (pair); - key_symbol = XCAR (pair); - value = XCDR (pair); - } - CHECK_SYMBOL (key_symbol); - Lisp_Object key = SYMBOL_NAME (key_symbol); - /* We can't specify the length, so the string must be - null-terminated. */ - check_string_without_embedded_nulls (key); - key_str = SSDATA (key); - /* In plists, ensure leading ":" in keys is stripped. It - will be reconstructed later in `json_to_lisp'.*/ - if (is_plist && ':' == key_str[0] && key_str[1]) - { - key_str = &key_str[1]; - } - /* Only add element if key is not already present. */ - if (json_object_get (json, key_str) == NULL) - { - int status - = json_object_set_new (json, key_str, lisp_to_json (value, - conf)); - if (status == -1) - json_out_of_memory (); - } - } - CHECK_LIST_END (tail, lisp); - } - else - wrong_type_argument (Qjson_value_p, lisp); - - clear_unwind_protect (count); - unbind_to (count, Qnil); - return json; + json_out_byte (jo, '"'); } -/* Convert LISP to a nonscalar JSON object (array or object). Signal - an error of type `wrong-type-argument' if LISP is not a vector, - hashtable, alist, or plist. */ +static void +json_out_nest (json_out_t *jo) +{ + --jo->maxdepth; + if (jo->maxdepth < 0) + error ("Maximum JSON serialisation depth exceeded"); +} -static json_t * -lisp_to_json_nonscalar (Lisp_Object lisp, - const struct json_configuration *conf) +static void +json_out_unnest (json_out_t *jo) { - if (++lisp_eval_depth > max_lisp_eval_depth) - xsignal0 (Qjson_object_too_deep); - json_t *json = lisp_to_json_nonscalar_1 (lisp, conf); - --lisp_eval_depth; - return json; + ++jo->maxdepth; } -/* Convert LISP to any JSON object. Signal an error of type - `wrong-type-argument' if the type of LISP can't be converted to a - JSON object. */ +static void json_out_something (json_out_t *jo, Lisp_Object obj); -static json_t * -lisp_to_json (Lisp_Object lisp, const struct json_configuration *conf) +static void +json_out_object_cons (json_out_t *jo, Lisp_Object obj) { - if (EQ (lisp, conf->null_object)) - return json_check (json_null ()); - else if (EQ (lisp, conf->false_object)) - return json_check (json_false ()); - else if (EQ (lisp, Qt)) - return json_check (json_true ()); - else if (INTEGERP (lisp)) + json_out_nest (jo); + symset_t ss = push_symset (jo); + json_out_byte (jo, '{'); + bool is_alist = CONSP (XCAR (obj)); + bool first = true; + Lisp_Object tail = obj; + FOR_EACH_TAIL (tail) { - intmax_t low = TYPE_MINIMUM (json_int_t); - intmax_t high = TYPE_MAXIMUM (json_int_t); - intmax_t value = check_integer_range (lisp, low, high); - return json_check (json_integer (value)); + Lisp_Object key; + Lisp_Object value; + if (is_alist) + { + Lisp_Object pair = XCAR (tail); + CHECK_CONS (pair); + key = XCAR (pair); + value = XCDR (pair); + } + else + { + key = XCAR (tail); + tail = XCDR (tail); + CHECK_CONS (tail); + value = XCAR (tail); + } + key = maybe_remove_pos_from_symbol (key); + CHECK_TYPE (BARE_SYMBOL_P (key), Qsymbolp, key); + + if (symset_add (jo, &ss, key)) + { + if (!first) + json_out_byte (jo, ','); + first = false; + + Lisp_Object key_str = SYMBOL_NAME (key); + const char *str = SSDATA (key_str); + /* Skip leading ':' in plist keys. */ + int skip = !is_alist && str[0] == ':' && str[1] ? 1 : 0; + json_out_string (jo, key_str, skip); + json_out_byte (jo, ':'); + json_out_something (jo, value); + } } - else if (FLOATP (lisp)) - return json_check (json_real (XFLOAT_DATA (lisp))); - else if (STRINGP (lisp)) + CHECK_LIST_END (tail, obj); + json_out_byte (jo, '}'); + pop_symset (jo, &ss); + json_out_unnest (jo); +} + +static void +json_out_object_hash (json_out_t *jo, Lisp_Object obj) +{ + json_out_nest (jo); + json_out_byte (jo, '{'); + struct Lisp_Hash_Table *h = XHASH_TABLE (obj); + bool first = true; + DOHASH (h, k, v) { - Lisp_Object encoded = json_encode (lisp); - json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded)); - if (json == NULL) - { - /* A failure can be caused either by an invalid string or by - low memory. */ - json_check_utf8 (encoded); - json_out_of_memory (); - } - return json; + if (!first) + json_out_byte (jo, ','); + first = false; + CHECK_STRING (k); + /* It's the user's responsibility to ensure that hash keys are + unique; we don't check for it. */ + json_out_string (jo, k, 0); + json_out_byte (jo, ':'); + json_out_something (jo, v); } + json_out_byte (jo, '}'); + json_out_unnest (jo); - /* LISP now must be a vector, hashtable, alist, or plist. */ - return lisp_to_json_nonscalar (lisp, conf); } static void -json_parse_args (ptrdiff_t nargs, - Lisp_Object *args, - struct json_configuration *conf, - bool parse_object_types) +json_out_array (json_out_t *jo, Lisp_Object obj) { - if ((nargs % 2) != 0) - wrong_type_argument (Qplistp, Flist (nargs, args)); + json_out_nest (jo); + json_out_byte (jo, '['); + ptrdiff_t n = ASIZE (obj); + for (ptrdiff_t i = 0; i < n; i++) + { + if (i > 0) + json_out_byte (jo, ','); + json_out_something (jo, AREF (obj, i)); + } + json_out_byte (jo, ']'); + json_out_unnest (jo); +} - /* Start from the back so keyword values appearing - first take precedence. */ - for (ptrdiff_t i = nargs; i > 0; i -= 2) { - Lisp_Object key = args[i - 2]; - Lisp_Object value = args[i - 1]; - if (parse_object_types && EQ (key, QCobject_type)) - { - if (EQ (value, Qhash_table)) - conf->object_type = json_object_hashtable; - else if (EQ (value, Qalist)) - conf->object_type = json_object_alist; - else if (EQ (value, Qplist)) - conf->object_type = json_object_plist; - else - wrong_choice (list3 (Qhash_table, Qalist, Qplist), value); - } - else if (parse_object_types && EQ (key, QCarray_type)) - { - if (EQ (value, Qarray)) - conf->array_type = json_array_array; - else if (EQ (value, Qlist)) - conf->array_type = json_array_list; - else - wrong_choice (list2 (Qarray, Qlist), value); - } - else if (EQ (key, QCnull_object)) - conf->null_object = value; - else if (EQ (key, QCfalse_object)) - conf->false_object = value; - else if (parse_object_types) - wrong_choice (list4 (QCobject_type, - QCarray_type, - QCnull_object, - QCfalse_object), - value); - else - wrong_choice (list2 (QCnull_object, - QCfalse_object), - value); - } +static void +json_out_float (json_out_t *jo, Lisp_Object f) +{ + double x = XFLOAT_DATA (f); + if (!isfinite (x)) + signal_error ("JSON does not allow Inf or NaN", f); + /* As luck has it, float_to_string emits correct JSON float syntax for + all numbers (because Vfloat_output_format is Qnil). */ + json_make_room (jo, FLOAT_TO_STRING_BUFSIZE); + int n = float_to_string (jo->buf + jo->size, x); + jo->size += n; } -static bool -json_available_p (void) +static void +json_out_bignum (json_out_t *jo, Lisp_Object x) { -#ifdef WINDOWSNT - if (!json_initialized) - { - Lisp_Object status; - json_initialized = init_json_functions (); - status = json_initialized ? Qt : Qnil; - Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); - } - return json_initialized; -#else /* !WINDOWSNT */ - return true; -#endif + int base = 10; + ptrdiff_t size = bignum_bufsize (x, base); + json_make_room (jo, size); + int n = bignum_to_c_string (jo->buf + jo->size, size, x, base); + jo->size += n; } -#ifdef WINDOWSNT static void -ensure_json_available (void) +json_out_something (json_out_t *jo, Lisp_Object obj) { - if (!json_available_p ()) - Fsignal (Qjson_unavailable, - list1 (build_unibyte_string ("jansson library not found"))); + if (EQ (obj, jo->conf.null_object)) + JSON_OUT_STR (jo, "null"); + else if (EQ (obj, jo->conf.false_object)) + JSON_OUT_STR (jo, "false"); + else if (EQ (obj, Qt)) + JSON_OUT_STR (jo, "true"); + else if (NILP (obj)) + JSON_OUT_STR (jo, "{}"); + else if (FIXNUMP (obj)) + json_out_fixnum (jo, XFIXNUM (obj)); + else if (STRINGP (obj)) + json_out_string (jo, obj, 0); + else if (CONSP (obj)) + json_out_object_cons (jo, obj); + else if (FLOATP (obj)) + json_out_float (jo, obj); + else if (HASH_TABLE_P (obj)) + json_out_object_hash (jo, obj); + else if (VECTORP (obj)) + json_out_array (jo, obj); + else if (BIGNUMP (obj)) + json_out_bignum (jo, obj); + else + wrong_type_argument (Qjson_value_p, obj); } -#endif -DEFUN ("json--available-p", Fjson__available_p, Sjson__available_p, 0, 0, NULL, - doc: /* Return non-nil if libjansson is available (internal use only). */) - (void) +static Lisp_Object +json_out_to_string (json_out_t *jo) { - return json_available_p () ? Qt : Qnil; + /* FIXME: should this be a unibyte or multibyte string? + Right now we make a multibyte string for test compatibility, + but we are really encoding so unibyte would make more sense. */ + ptrdiff_t nchars = jo->size - jo->chars_delta; + return make_multibyte_string (jo->buf, nchars, jo->size); +} + +static void +json_serialize (json_out_t *jo, Lisp_Object object, + ptrdiff_t nargs, Lisp_Object *args) +{ + jo->maxdepth = 50; + jo->size = 0; + jo->capacity = 0; + jo->chars_delta = 0; + jo->buf = NULL; + jo->ss_table = NULL; + jo->conf.object_type = json_object_hashtable; + jo->conf.array_type = json_array_array; + jo->conf.null_object = QCnull; + jo->conf.false_object = QCfalse; + + json_parse_args (nargs, args, &jo->conf, false); + record_unwind_protect_ptr (cleanup_json_out, jo); + + /* Make float conversion independent of float-output-format. */ + if (!NILP (Vfloat_output_format)) + specbind (Qfloat_output_format, Qnil); + + json_out_something (jo, object); } DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY, NULL, doc: /* Return the JSON representation of OBJECT as a string. -OBJECT must be t, a number, string, vector, hashtable, alist, plist, -or the Lisp equivalents to the JSON null and false values, and its -elements must recursively consist of the same kinds of values. t will -be converted to the JSON true value. Vectors will be converted to -JSON arrays, whereas hashtables, alists and plists are converted to -JSON objects. Hashtable keys must be strings without embedded null -characters and must be unique within each object. Alist and plist -keys must be symbols; if a key is duplicate, the first instance is -used. +OBJECT is translated as follows: + +`t' -- the JSON `true' value. +number -- a JSON number. +string -- a JSON string. +vector -- a JSON array. +hash-table -- a JSON object. Keys must be strings. +alist -- a JSON object. Keys must be symbols. +plist -- a JSON object. Keys must be symbols. + A leading colon in plist key names is elided. + +For duplicate object keys, the first value is used. The Lisp equivalents to the JSON null and false values are configurable in the arguments ARGS, a list of keyword/argument pairs: -The keyword argument `:null-object' specifies which object to use -to represent a JSON null value. It defaults to `:null'. +:null-object OBJ -- use OBJ to represent a JSON null value. + It defaults to `:null'. -The keyword argument `:false-object' specifies which object to use to -represent a JSON false value. It defaults to `:false'. +:false-object OBJ -- use OBJ to represent a JSON false value. + It defaults to `:false'. In you specify the same value for `:null-object' and `:false-object', a potentially ambiguous situation, the JSON output will not contain any JSON false values. usage: (json-serialize OBJECT &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) + (ptrdiff_t nargs, Lisp_Object *args) { specpdl_ref count = SPECPDL_INDEX (); - -#ifdef WINDOWSNT - ensure_json_available (); -#endif - - struct json_configuration conf = - {json_object_hashtable, json_array_array, QCnull, QCfalse}; - json_parse_args (nargs - 1, args + 1, &conf, false); - - json_t *json = lisp_to_json (args[0], &conf); - record_unwind_protect_ptr (json_release_object, json); - - char *string = json_dumps (json, JSON_COMPACT | JSON_ENCODE_ANY); - if (string == NULL) - json_out_of_memory (); - record_unwind_protect_ptr (json_free, string); - - return unbind_to (count, build_string_from_utf8 (string)); -} - -struct json_buffer_and_size -{ - const char *buffer; - ptrdiff_t size; - /* This tracks how many bytes were inserted by the callback since - json_dump_callback was called. */ - ptrdiff_t inserted_bytes; -}; - -static Lisp_Object -json_insert (void *data) -{ - struct json_buffer_and_size *buffer_and_size = data; - ptrdiff_t len = buffer_and_size->size; - ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes; - ptrdiff_t gap_size = GAP_SIZE - inserted_bytes; - - /* Enlarge the gap if necessary. */ - if (gap_size < len) - make_gap (len - gap_size); - - /* Copy this chunk of data into the gap. */ - memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes, - buffer_and_size->buffer, len); - buffer_and_size->inserted_bytes += len; - return Qnil; -} - -static Lisp_Object -json_handle_nonlocal_exit (enum nonlocal_exit type, Lisp_Object data) -{ - switch (type) - { - case NONLOCAL_EXIT_SIGNAL: - return data; - case NONLOCAL_EXIT_THROW: - return Fcons (Qno_catch, data); - default: - eassume (false); - } -} - -struct json_insert_data -{ - /* This tracks how many bytes were inserted by the callback since - json_dump_callback was called. */ - ptrdiff_t inserted_bytes; - /* nil if json_insert succeeded, otherwise the symbol - Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ - Lisp_Object error; -}; - -/* Callback for json_dump_callback that inserts a JSON representation - as a unibyte string into the gap. DATA must point to a structure - of type json_insert_data. This function may not exit nonlocally. - It catches all nonlocal exits and stores them in data->error for - reraising. */ - -static int -json_insert_callback (const char *buffer, size_t size, void *data) -{ - struct json_insert_data *d = data; - struct json_buffer_and_size buffer_and_size - = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes}; - d->error = internal_catch_all (json_insert, &buffer_and_size, - json_handle_nonlocal_exit); - d->inserted_bytes = buffer_and_size.inserted_bytes; - return NILP (d->error) ? 0 : -1; + json_out_t jo; + json_serialize (&jo, args[0], nargs - 1, args + 1); + return unbind_to (count, json_out_to_string (&jo)); } DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY, NULL, doc: /* Insert the JSON representation of OBJECT before point. -This is the same as (insert (json-serialize OBJECT)), but potentially -faster. See the function `json-serialize' for allowed values of -OBJECT. +This is the same as (insert (json-serialize OBJECT ...)), but potentially +faster, and with the difference that Unicode characters are inserted as +themselves into multibyte buffers, and as UTF-8 byte sequences into +unibyte buffers. +See the function `json-serialize' for allowed values of OBJECT and ARGS. usage: (json-insert OBJECT &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) + (ptrdiff_t nargs, Lisp_Object *args) { specpdl_ref count = SPECPDL_INDEX (); - -#ifdef WINDOWSNT - ensure_json_available (); -#endif - - struct json_configuration conf = - {json_object_hashtable, json_array_array, QCnull, QCfalse}; - json_parse_args (nargs - 1, args + 1, &conf, false); - - json_t *json = lisp_to_json (args[0], &conf); - record_unwind_protect_ptr (json_release_object, json); + json_out_t jo; + json_serialize (&jo, args[0], nargs - 1, args + 1); prepare_to_modify_buffer (PT, PT, NULL); move_gap_both (PT, PT_BYTE); - struct json_insert_data data; - data.inserted_bytes = 0; - /* Could have used json_dumpb, but that became available only in - Jansson 2.10, whereas we want to support 2.7 and upward. */ - int status = json_dump_callback (json, json_insert_callback, &data, - JSON_COMPACT | JSON_ENCODE_ANY); - if (status == -1) - { - if (CONSP (data.error)) - xsignal (XCAR (data.error), XCDR (data.error)); - else - json_out_of_memory (); - } + if (GAP_SIZE < jo.size) + make_gap (jo.size - GAP_SIZE); + memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE, jo.buf, jo.size); - ptrdiff_t inserted = 0; - ptrdiff_t inserted_bytes = data.inserted_bytes; - if (inserted_bytes > 0) - { - /* If required, decode the stuff we've read into the gap. */ - struct coding_system coding; - /* JSON strings are UTF-8 encoded strings. If for some reason - the text returned by the Jansson library includes invalid - byte sequences, they will be represented by raw bytes in the - buffer text. */ - setup_coding_system (Qutf_8_unix, &coding); - coding.dst_multibyte = - !NILP (BVAR (current_buffer, enable_multibyte_characters)); - if (CODING_MAY_REQUIRE_DECODING (&coding)) - { - /* Now we have all the new bytes at the beginning of the gap, - but `decode_coding_gap` needs them at the end of the gap, so - we need to move them. */ - memmove (GAP_END_ADDR - inserted_bytes, GPT_ADDR, inserted_bytes); - decode_coding_gap (&coding, inserted_bytes); - inserted = coding.produced_char; - } - else - { - /* Make the inserted text part of the buffer, as unibyte text. */ - eassert (NILP (BVAR (current_buffer, enable_multibyte_characters))); - insert_from_gap_1 (inserted_bytes, inserted_bytes, false); - - /* The target buffer is unibyte, so we don't need to decode. */ - invalidate_buffer_caches (current_buffer, - PT, PT + inserted_bytes); - adjust_after_insert (PT, PT_BYTE, - PT + inserted_bytes, - PT_BYTE + inserted_bytes, - inserted_bytes); - inserted = inserted_bytes; - } - } + /* No need to keep allocation beyond this point. */ + unbind_to (count, Qnil); + + bool ub_buffer = NILP (BVAR (current_buffer, enable_multibyte_characters)); + ptrdiff_t inserted_bytes = jo.size; + ptrdiff_t inserted = ub_buffer ? jo.size : jo.size - jo.chars_delta; + eassert (inserted > 0); + + insert_from_gap_1 (inserted, inserted_bytes, false); + invalidate_buffer_caches (current_buffer, PT, PT + inserted); + adjust_after_insert (PT, PT_BYTE, PT + inserted, PT_BYTE + inserted_bytes, + inserted); /* Call after-change hooks. */ signal_after_change (PT, 0, inserted); - if (inserted > 0) - { - update_compositions (PT, PT, CHECK_BORDER); - /* Move point to after the inserted text. */ - SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes); - } - return unbind_to (count, Qnil); + update_compositions (PT, PT, CHECK_BORDER); + /* Move point to after the inserted text. */ + SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes); + + return Qnil; } + #define JSON_PARSER_INTERNAL_OBJECT_WORKSPACE_SIZE 64 #define JSON_PARSER_INTERNAL_BYTE_WORKSPACE_SIZE 512 @@ -749,9 +733,9 @@ static AVOID json_signal_error (struct json_parser *parser, Lisp_Object error) { xsignal3 (error, INT_TO_INTEGER (parser->current_line), - INT_TO_INTEGER (parser->current_column), - INT_TO_INTEGER (parser->point_of_current_line - + parser->current_column)); + INT_TO_INTEGER (parser->current_column), + INT_TO_INTEGER (parser->point_of_current_line + + parser->current_column)); } static void @@ -801,9 +785,8 @@ json_parser_init (struct json_parser *parser, parser->object_workspace_current = 0; parser->byte_workspace = parser->internal_byte_workspace; - parser->byte_workspace_end - = (parser->byte_workspace - + JSON_PARSER_INTERNAL_BYTE_WORKSPACE_SIZE); + parser->byte_workspace_end = (parser->byte_workspace + + JSON_PARSER_INTERNAL_BYTE_WORKSPACE_SIZE); } static void @@ -1058,52 +1041,21 @@ json_parse_unicode (struct json_parser *parser) return v[0] << 12 | v[1] << 8 | v[2] << 4 | v[3]; } -/* Parses an utf-8 code-point encoding (except the first byte), and - returns the numeric value of the code-point (without considering - the first byte) */ -static int -json_handle_utf8_tail_bytes (struct json_parser *parser, int n) +static AVOID +utf8_error (struct json_parser *parser) { - int v = 0; - for (int i = 0; i < n; i++) - { - int c = json_input_get (parser); - json_byte_workspace_put (parser, c); - if ((c & 0xc0) != 0x80) - json_signal_error (parser, Qjson_utf8_decode_error); - v = (v << 6) | (c & 0x3f); - } - return v; + json_signal_error (parser, Qjson_utf8_decode_error); } -/* Reads a JSON string, and puts the result into the byte workspace */ -static void -json_parse_string (struct json_parser *parser) -{ - /* a single_uninteresting byte can be simply copied from the input - to output, it doesn't need any extra care. This means all the - characters between [0x20;0x7f], except the double quote and - the backslash */ - static const char is_single_uninteresting[256] = { - /* 0 1 2 3 4 5 6 7 8 9 a b c d e f */ - /* 0 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* 1 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* 2 */ 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - /* 3 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - /* 4 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - /* 5 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, - /* 6 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - /* 7 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - /* 8 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* 9 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* a */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* b */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* c */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* d */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* e */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* f */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - }; - +/* Parse a string literal. Optionally prepend a ':'. + Return the string or an interned symbol. */ +static Lisp_Object +json_parse_string (struct json_parser *parser, bool intern, bool leading_colon) +{ + json_byte_workspace_reset (parser); + if (leading_colon) + json_byte_workspace_put (parser, ':'); + ptrdiff_t chars_delta = 0; /* nbytes - nchars */ for (;;) { /* This if is only here for a possible speedup. If there are 4 @@ -1115,10 +1067,10 @@ json_parse_string (struct json_parser *parser) int c1 = parser->input_current[1]; int c2 = parser->input_current[2]; int c3 = parser->input_current[3]; - bool v0 = is_single_uninteresting[c0]; - bool v1 = is_single_uninteresting[c1]; - bool v2 = is_single_uninteresting[c2]; - bool v3 = is_single_uninteresting[c3]; + bool v0 = json_plain_char[c0]; + bool v1 = json_plain_char[c1]; + bool v2 = json_plain_char[c2]; + bool v3 = json_plain_char[c3]; if (v0 && v1 && v2 && v3) { json_byte_workspace_put (parser, c0); @@ -1133,43 +1085,63 @@ json_parse_string (struct json_parser *parser) int c = json_input_get (parser); parser->current_column++; - if (is_single_uninteresting[c]) + if (json_plain_char[c]) { json_byte_workspace_put (parser, c); continue; } if (c == '"') - return; - else if (c & 0x80) { - /* Handle utf-8 encoding */ + ptrdiff_t nbytes + = parser->byte_workspace_current - parser->byte_workspace; + ptrdiff_t nchars = nbytes - chars_delta; + const char *str = (const char *) parser->byte_workspace; + return (intern + ? intern_c_multibyte (str, nchars, nbytes) + : make_multibyte_string (str, nchars, nbytes)); + } + + if (c & 0x80) + { + /* Parse UTF-8, strictly. This is the correct thing to do + whether the input is a unibyte or multibyte string. */ json_byte_workspace_put (parser, c); - if (c < 0xc0) - json_signal_error (parser, Qjson_utf8_decode_error); - else if (c < 0xe0) - { - int n = ((c & 0x1f) << 6 - | json_handle_utf8_tail_bytes (parser, 1)); - if (n < 0x80) - json_signal_error (parser, Qjson_utf8_decode_error); - } - else if (c < 0xf0) + unsigned char c1 = json_input_get (parser); + if ((c1 & 0xc0) != 0x80) + utf8_error (parser); + json_byte_workspace_put (parser, c1); + if (c <= 0xc1) + utf8_error (parser); + else if (c <= 0xdf) + chars_delta += 1; + else if (c <= 0xef) { - int n = ((c & 0xf) << 12 - | json_handle_utf8_tail_bytes (parser, 2)); - if (n < 0x800 || (n >= 0xd800 && n < 0xe000)) - json_signal_error (parser, Qjson_utf8_decode_error); + unsigned char c2 = json_input_get (parser); + if ((c2 & 0xc0) != 0x80) + utf8_error (parser); + int v = ((c & 0x0f) << 12) + ((c1 & 0x3f) << 6) + (c2 & 0x3f); + if (v < 0x800 || (v >= 0xd800 && v <= 0xdfff)) + utf8_error (parser); + json_byte_workspace_put (parser, c2); + chars_delta += 2; } - else if (c < 0xf8) + else if (c <= 0xf7) { - int n = ((c & 0x7) << 18 - | json_handle_utf8_tail_bytes (parser, 3)); - if (n < 0x10000 || n > 0x10ffff) - json_signal_error (parser, Qjson_utf8_decode_error); + unsigned char c2 = json_input_get (parser); + unsigned char c3 = json_input_get (parser); + if ((c2 & 0xc0) != 0x80 || (c3 & 0xc0) != 0x80) + utf8_error (parser); + int v = (((c & 0x07) << 18) + ((c1 & 0x3f) << 12) + + ((c2 & 0x3f) << 6) + (c3 & 0x3f)); + if (v < 0x10000 || v > 0x10ffff) + utf8_error (parser); + json_byte_workspace_put (parser, c2); + json_byte_workspace_put (parser, c3); + chars_delta += 3; } else - json_signal_error (parser, Qjson_utf8_decode_error); + utf8_error (parser); } else if (c == '\\') { @@ -1210,8 +1182,7 @@ json_parse_string (struct json_parser *parser) if (num2 < 0xdc00 || num2 >= 0xe000) json_signal_error (parser, Qjson_invalid_surrogate_error); - num = (0x10000 - + ((num - 0xd800) << 10 | (num2 - 0xdc00))); + num = (0x10000 + ((num - 0xd800) << 10 | (num2 - 0xdc00))); } else if (num >= 0xdc00 && num < 0xe000) /* is the second half of the surrogate pair without @@ -1227,6 +1198,7 @@ json_parse_string (struct json_parser *parser) json_byte_workspace_put (parser, 0xc0 | num >> 6); json_byte_workspace_put (parser, 0x80 | (num & 0x3f)); + chars_delta += 1; } else if (num < 0x10000) { @@ -1236,6 +1208,7 @@ json_parse_string (struct json_parser *parser) | ((num >> 6) & 0x3f))); json_byte_workspace_put (parser, 0x80 | (num & 0x3f)); + chars_delta += 2; } else { @@ -1248,6 +1221,7 @@ json_parse_string (struct json_parser *parser) | ((num >> 6) & 0x3f))); json_byte_workspace_put (parser, 0x80 | (num & 0x3f)); + chars_delta += 3; } } else @@ -1284,10 +1258,8 @@ json_create_integer (struct json_parser *parser, json_byte_workspace_put (parser, 0); ptrdiff_t len; Lisp_Object result - = string_to_number ((const char *) parser->byte_workspace, 10, - &len); - if (len - != parser->byte_workspace_current - parser->byte_workspace - 1) + = string_to_number ((const char *) parser->byte_workspace, 10, &len); + if (len != parser->byte_workspace_current - parser->byte_workspace - 1) json_signal_error (parser, Qjson_error); return result; } @@ -1300,12 +1272,10 @@ json_create_float (struct json_parser *parser) errno = 0; char *e; double value = strtod ((const char *) parser->byte_workspace, &e); - bool out_of_range - = (errno != 0 && (value == HUGE_VAL || value == -HUGE_VAL)); + bool out_of_range = (errno != 0 && (value == HUGE_VAL || value == -HUGE_VAL)); if (out_of_range) json_signal_error (parser, Qjson_number_out_of_range); - else if ((const unsigned char *) e - != parser->byte_workspace_current - 1) + else if ((const unsigned char *) e != parser->byte_workspace_current - 1) json_signal_error (parser, Qjson_error); else return make_float (value); @@ -1445,7 +1415,6 @@ json_parse_array (struct json_parser *parser) if (parser->available_depth < 0) json_signal_error (parser, Qjson_object_too_deep); - size_t number_of_elements = 0; Lisp_Object *cdr = &result; /* This loop collects the array elements in the object workspace */ @@ -1472,8 +1441,6 @@ json_parse_array (struct json_parser *parser) } c = json_skip_whitespace (parser); - - number_of_elements++; if (c == ']') { parser->available_depth++; @@ -1548,39 +1515,23 @@ json_parse_object (struct json_parser *parser) if (c != '"') json_signal_error (parser, Qjson_parse_error); - json_byte_workspace_reset (parser); switch (parser->conf.object_type) { case json_object_hashtable: { - json_parse_string (parser); - Lisp_Object key - = make_string_from_utf8 ((char *) - parser->byte_workspace, - (parser->byte_workspace_current - - parser->byte_workspace)); - Lisp_Object value - = json_parse_object_member_value (parser); + Lisp_Object key = json_parse_string (parser, false, false); + Lisp_Object value = json_parse_object_member_value (parser); json_make_object_workspace_for (parser, 2); - parser->object_workspace[parser->object_workspace_current] - = key; + parser->object_workspace[parser->object_workspace_current] = key; parser->object_workspace_current++; - parser->object_workspace[parser->object_workspace_current] - = value; + parser->object_workspace[parser->object_workspace_current] = value; parser->object_workspace_current++; break; } case json_object_alist: { - json_parse_string (parser); - Lisp_Object key - = Fintern (make_string_from_utf8 ( - (char *) parser->byte_workspace, - (parser->byte_workspace_current - - parser->byte_workspace)), - Qnil); - Lisp_Object value - = json_parse_object_member_value (parser); + Lisp_Object key = json_parse_string (parser, true, false); + Lisp_Object value = json_parse_object_member_value (parser); Lisp_Object nc = Fcons (Fcons (key, value), Qnil); *cdr = nc; cdr = xcdr_addr (nc); @@ -1588,14 +1539,8 @@ json_parse_object (struct json_parser *parser) } case json_object_plist: { - json_byte_workspace_put (parser, ':'); - json_parse_string (parser); - Lisp_Object key - = intern_1 ((char *) parser->byte_workspace, - (parser->byte_workspace_current - - parser->byte_workspace)); - Lisp_Object value - = json_parse_object_member_value (parser); + Lisp_Object key = json_parse_string (parser, true, true); + Lisp_Object value = json_parse_object_member_value (parser); Lisp_Object nc = Fcons (key, Qnil); *cdr = nc; cdr = xcdr_addr (nc); @@ -1628,13 +1573,10 @@ json_parse_object (struct json_parser *parser) { case json_object_hashtable: { - result - = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize, - make_fixed_natnum ( - (parser->object_workspace_current - first) / 2)); + EMACS_INT value = (parser->object_workspace_current - first) / 2; + result = make_hash_table (&hashtest_equal, value, Weak_None, false); struct Lisp_Hash_Table *h = XHASH_TABLE (result); - for (size_t i = first; i < parser->object_workspace_current; - i += 2) + for (size_t i = first; i < parser->object_workspace_current; i += 2) { hash_hash_t hash; Lisp_Object key = parser->object_workspace[i]; @@ -1683,23 +1625,14 @@ json_parse_value (struct json_parser *parser, int c) else if (c == '[') return json_parse_array (parser); else if (c == '"') - { - json_byte_workspace_reset (parser); - json_parse_string (parser); - Lisp_Object result - = make_string_from_utf8 ((const char *) - parser->byte_workspace, - (parser->byte_workspace_current - - parser->byte_workspace)); - return result; - } + return json_parse_string (parser, false, false); else if ((c >= '0' && c <= '9') || (c == '-')) return json_parse_number (parser, c); else { - int c2 = json_input_get (parser); - int c3 = json_input_get (parser); - int c4 = json_input_get (parser); + int c2 = json_input_get_if_possible (parser); + int c3 = json_input_get_if_possible (parser); + int c4 = json_input_get_if_possible (parser); int c5 = json_input_get_if_possible (parser); if (c == 't' && c2 == 'r' && c3 == 'u' && c4 == 'e' @@ -1758,15 +1691,13 @@ json_parse (struct json_parser *parser, break; case PARSEENDBEHAVIOR_MovePoint: { - ptrdiff_t byte - = (PT_BYTE + parser->input_current - parser->input_begin - + parser->additional_bytes_count); + ptrdiff_t byte = (PT_BYTE + parser->input_current - parser->input_begin + + parser->additional_bytes_count); ptrdiff_t position; if (NILP (BVAR (current_buffer, enable_multibyte_characters))) position = byte; else - position - = PT + parser->point_of_current_line + parser->current_column; + position = PT + parser->point_of_current_line + parser->current_column; SET_PT_BOTH (position, byte); break; @@ -1778,31 +1709,30 @@ json_parse (struct json_parser *parser, DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY, NULL, - doc: /* Parse the JSON STRING into a Lisp object. + doc: /* Parse the JSON STRING into a Lisp value. This is essentially the reverse operation of `json-serialize', which -see. The returned object will be the JSON null value, the JSON false -value, t, a number, a string, a vector, a list, a hashtable, an alist, -or a plist. Its elements will be further objects of these types. If -there are duplicate keys in an object, all but the last one are -ignored. If STRING doesn't contain a valid JSON object, this function +see. The returned value will be the JSON null value, the JSON false +value, t, a number, a string, a vector, a list, a hash-table, an alist, +or a plist. Its elements will be further values of these types. +If STRING doesn't contain a valid JSON value, this function signals an error of type `json-parse-error'. The arguments ARGS are a list of keyword/argument pairs: -The keyword argument `:object-type' specifies which Lisp type is used -to represent objects; it can be `hash-table', `alist' or `plist'. It -defaults to `hash-table'. If an object has members with the same -key, `hash-table' keeps only the last value of such keys, while -`alist' and `plist' keep all the members. +:object-type TYPE -- use TYPE to represent JSON objects. + TYPE can be `hash-table' (the default), `alist' or `plist'. + If an object has members with the same key, `hash-table' keeps only + the last value of such keys, while `alist' and `plist' keep all the + members. -The keyword argument `:array-type' specifies which Lisp type is used -to represent arrays; it can be `array' (the default) or `list'. +:array-type TYPE -- use TYPE to represent JSON arrays. + TYPE can be `array' (the default) or `list'. -The keyword argument `:null-object' specifies which object to use -to represent a JSON null value. It defaults to `:null'. +:null-object OBJ -- use OBJ to represent a JSON null value. + It defaults to `:null'. -The keyword argument `:false-object' specifies which object to use to -represent a JSON false value. It defaults to `:false'. +:false-object OBJ -- use OBJ to represent a JSON false value. + It defaults to `:false'. usage: (json-parse-string STRING &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { @@ -1810,16 +1740,13 @@ usage: (json-parse-string STRING &rest ARGS) */) Lisp_Object string = args[0]; CHECK_STRING (string); - Lisp_Object encoded = json_encode (string); struct json_configuration conf = { json_object_hashtable, json_array_array, QCnull, QCfalse }; json_parse_args (nargs - 1, args + 1, &conf, true); struct json_parser p; - const unsigned char *begin - = (const unsigned char *) SSDATA (encoded); - json_parser_init (&p, conf, begin, begin + SBYTES (encoded), NULL, - NULL); + const unsigned char *begin = SDATA (string); + json_parser_init (&p, conf, begin, begin + SBYTES (string), NULL, NULL); record_unwind_protect_ptr (json_parser_done, &p); return unbind_to (count, @@ -1829,35 +1756,34 @@ usage: (json-parse-string STRING &rest ARGS) */) DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, 0, MANY, NULL, - doc: /* Read JSON object from current buffer starting at point. -Move point after the end of the object if parsing was successful. + doc: /* Read a JSON value from current buffer starting at point. +Move point after the end of the value if parsing was successful. On error, don't move point. -The returned object will be a vector, list, hashtable, alist, or +The returned value will be a vector, list, hashtable, alist, or plist. Its elements will be the JSON null value, the JSON false value, t, numbers, strings, or further vectors, lists, hashtables, -alists, or plists. If there are duplicate keys in an object, all -but the last one are ignored. +alists, or plists. -If the current buffer doesn't contain a valid JSON object, the +If the current buffer doesn't contain a valid JSON value, the function signals an error of type `json-parse-error'. The arguments ARGS are a list of keyword/argument pairs: -The keyword argument `:object-type' specifies which Lisp type is used -to represent objects; it can be `hash-table', `alist' or `plist'. It -defaults to `hash-table'. If an object has members with the same -key, `hash-table' keeps only the last value of such keys, while -`alist' and `plist' keep all the members. +:object-type TYPE -- use TYPE to represent JSON objects. + TYPE can be `hash-table' (the default), `alist' or `plist'. + If an object has members with the same key, `hash-table' keeps only + the last value of such keys, while `alist' and `plist' keep all the + members. -The keyword argument `:array-type' specifies which Lisp type is used -to represent arrays; it can be `array' (the default) or `list'. +:array-type TYPE -- use TYPE to represent JSON arrays. + TYPE can be `array' (the default) or `list'. -The keyword argument `:null-object' specifies which object to use -to represent a JSON null value. It defaults to `:null'. +:null-object OBJ -- use OBJ to represent a JSON null value. + It defaults to `:null'. -The keyword argument `:false-object' specifies which object to use to -represent a JSON false value. It defaults to `:false'. +:false-object OBJ -- use OBJ to represent a JSON false value. + It defaults to `:false'. usage: (json-parse-buffer &rest args) */) (ptrdiff_t nargs, Lisp_Object *args) { @@ -1894,7 +1820,6 @@ syms_of_json (void) DEFSYM (QCnull, ":null"); DEFSYM (QCfalse, ":false"); - DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); DEFSYM (Qjson_value_p, "json-value-p"); DEFSYM (Qjson_error, "json-error"); @@ -1903,29 +1828,28 @@ syms_of_json (void) DEFSYM (Qjson_end_of_file, "json-end-of-file"); DEFSYM (Qjson_trailing_content, "json-trailing-content"); DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); - DEFSYM (Qjson_utf8_decode_error, "json-utf8-decode-error") - DEFSYM (Qjson_invalid_surrogate_error, "json-invalid-surrogate-error") - DEFSYM (Qjson_number_out_of_range, "json-number-out-of-range-error") - DEFSYM (Qjson_escape_sequence_error, "json-escape-sequence-error") - DEFSYM (Qjson_unavailable, "json-unavailable"); + DEFSYM (Qjson_utf8_decode_error, "json-utf8-decode-error"); + DEFSYM (Qjson_invalid_surrogate_error, "json-invalid-surrogate-error"); + DEFSYM (Qjson_number_out_of_range, "json-number-out-of-range-error"); + DEFSYM (Qjson_escape_sequence_error, "json-escape-sequence-error"); define_error (Qjson_error, "generic JSON error", Qerror); define_error (Qjson_out_of_memory, - "not enough memory for creating JSON object", Qjson_error); + "not enough memory for creating JSON object", Qjson_error); define_error (Qjson_parse_error, "could not parse JSON stream", - Qjson_error); + Qjson_error); define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error); define_error (Qjson_trailing_content, "trailing content after JSON stream", - Qjson_parse_error); + Qjson_parse_error); define_error (Qjson_object_too_deep, - "object cyclic or Lisp evaluation too deep", Qjson_error); + "object cyclic or Lisp evaluation too deep", Qjson_error); define_error (Qjson_utf8_decode_error, - "invalid utf-8 encoding", Qjson_error); + "invalid utf-8 encoding", Qjson_error); define_error (Qjson_invalid_surrogate_error, - "invalid surrogate pair", Qjson_error); + "invalid surrogate pair", Qjson_error); define_error (Qjson_number_out_of_range, - "number out of range", Qjson_error); + "number out of range", Qjson_error); define_error (Qjson_escape_sequence_error, - "invalid escape sequence", Qjson_parse_error); + "invalid escape sequence", Qjson_parse_error); DEFSYM (Qpure, "pure"); DEFSYM (Qside_effect_free, "side-effect-free"); @@ -1945,7 +1869,6 @@ syms_of_json (void) DEFSYM (Qplist, "plist"); DEFSYM (Qarray, "array"); - defsubr (&Sjson__available_p); defsubr (&Sjson_serialize); defsubr (&Sjson_insert); defsubr (&Sjson_parse_string); diff --git a/src/keyboard.c b/src/keyboard.c index 91faf4582fa..bd1bb3bb4be 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -98,6 +98,7 @@ char const DEV_TTY[] = "CONOUT$"; #else char const DEV_TTY[] = "/dev/tty"; #endif +char *dev_tty; /* set by init_keyboard */ /* Variables for blockinput.h: */ @@ -1645,7 +1646,7 @@ command_loop_1 (void) } if (current_buffer != prev_buffer || MODIFF != prev_modiff) - run_hook (intern ("activate-mark-hook")); + run_hook (Qactivate_mark_hook); } Vsaved_region_selection = Qnil; @@ -3076,7 +3077,7 @@ read_char (int commandflag, Lisp_Object map, #ifdef HAVE_NS if (CONSP (c) - && (EQ (XCAR (c), intern ("ns-unput-working-text")))) + && (EQ (XCAR (c), Qns_unput_working_text))) input_was_pending = input_pending; #endif @@ -4602,7 +4603,7 @@ timer_start_idle (void) timer_last_idleness_start_time = timer_idleness_start_time; /* Mark all idle-time timers as once again candidates for running. */ - call0 (intern ("internal-timer-start-idle")); + call0 (Qinternal_timer_start_idle); } /* Record that Emacs is no longer idle, so stop running idle-time timers. */ @@ -6639,8 +6640,17 @@ make_lispy_event (struct input_event *event) if (CONSP (event->arg)) return list5 (head, position, make_fixnum (double_click_count), - XCAR (event->arg), Fcons (XCAR (XCDR (event->arg)), - XCAR (XCDR (XCDR (event->arg))))); + XCAR (event->arg), + /* FIXME: When a mouse-click on a tab-bar is + converted into a wheel-event we get here something + of an unexpected shape... */ + (CONSP (XCDR (event->arg)) + && CONSP (XCDR (XCDR (event->arg)))) + ? Fcons (XCAR (XCDR (event->arg)), + XCAR (XCDR (XCDR (event->arg)))) + /* ... not knowing what this "unexpected shape" means, + we just use nil. */ + : Qnil); else if (NUMBERP (event->arg)) return list4 (head, position, make_fixnum (double_click_count), event->arg); @@ -10119,7 +10129,7 @@ read_char_minibuf_menu_prompt (int commandflag, } /* Prompt with that and read response. */ - message3_nolog (apply1 (intern ("concat"), Fnreverse (menu_strings))); + message3_nolog (apply1 (Qconcat, Fnreverse (menu_strings))); /* Make believe it's not a keyboard macro in case the help char is pressed. Help characters are not recorded because menu prompting @@ -11896,7 +11906,7 @@ On such systems, Emacs starts a subshell instead of suspending. */) if (!NILP (stuffstring)) CHECK_STRING (stuffstring); - run_hook (intern ("suspend-hook")); + run_hook (Qsuspend_hook); get_tty_size (fileno (CURTTY ()->input), &old_width, &old_height); reset_all_sys_modes (); @@ -11917,7 +11927,7 @@ On such systems, Emacs starts a subshell instead of suspending. */) if (width != old_width || height != old_height) change_frame_size (SELECTED_FRAME (), width, height, false, false, false); - run_hook (intern ("suspend-resume-hook")); + run_hook (Qsuspend_resume_hook); return Qnil; } @@ -11994,7 +12004,7 @@ static void handle_interrupt_signal (int sig) { /* See if we have an active terminal on our controlling tty. */ - struct terminal *terminal = get_named_terminal (DEV_TTY); + struct terminal *terminal = get_named_terminal (dev_tty); if (!terminal) { /* If there are no frames there, let's pretend that we are a @@ -12063,7 +12073,7 @@ handle_interrupt (bool in_signal_handler) cancel_echoing (); /* XXX This code needs to be revised for multi-tty support. */ - if (!NILP (Vquit_flag) && get_named_terminal (DEV_TTY)) + if (!NILP (Vquit_flag) && get_named_terminal (dev_tty)) { if (! in_signal_handler) { @@ -12356,7 +12366,7 @@ process. See also `current-input-mode'. */) (Lisp_Object quit) { - struct terminal *t = get_named_terminal (DEV_TTY); + struct terminal *t = get_named_terminal (dev_tty); struct tty_display_info *tty; if (!t) @@ -13692,7 +13702,7 @@ you could say something like: Also see `set-message-function' (which controls how non-error messages are displayed). */); - Vcommand_error_function = intern ("command-error-default-function"); + Vcommand_error_function = Qcommand_error_default_function; DEFVAR_LISP ("enable-disabled-menus-and-buttons", Venable_disabled_menus_and_buttons, @@ -13742,7 +13752,7 @@ of processing the event normally through `special-event-map'. Currently, the only supported values for this variable are `sigusr1' and `sigusr2'. */); - Vdebug_on_event = intern_c_string ("sigusr2"); + Vdebug_on_event = Qsigusr2; DEFVAR_BOOL ("attempt-stack-overflow-recovery", attempt_stack_overflow_recovery, @@ -13844,6 +13854,15 @@ function is called to remap that sequence. */); DEFSYM (Qcurrent_key_remap_sequence, "current-key-remap-sequence"); pdumper_do_now_and_after_load (syms_of_keyboard_for_pdumper); + + DEFSYM (Qactivate_mark_hook, "activate-mark-hook"); + DEFSYM (Qns_unput_working_text, "ns-unput-working-text"); + DEFSYM (Qinternal_timer_start_idle, "internal-timer-start-idle"); + DEFSYM (Qconcat, "concat"); + DEFSYM (Qsuspend_hook, "suspend-hook"); + DEFSYM (Qsuspend_resume_hook, "suspend-resume-hook"); + DEFSYM (Qcommand_error_default_function, "command-error-default-function"); + DEFSYM (Qsigusr2, "sigusr2"); } static void diff --git a/src/keyboard.h b/src/keyboard.h index 2ce003fd444..42637ca1cf7 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -521,6 +521,9 @@ extern void mark_kboards (void); extern const char *const lispy_function_keys[]; #endif +/* Terminal device used by Emacs for terminal I/O. */ +extern char *dev_tty; +/* Initial value for dev_tty. */ extern char const DEV_TTY[]; INLINE_HEADER_END diff --git a/src/keymap.c b/src/keymap.c index 10378767c65..0f50d804dff 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -642,7 +642,7 @@ usage: (map-keymap FUNCTION KEYMAP) */) (Lisp_Object function, Lisp_Object keymap, Lisp_Object sort_first) { if (! NILP (sort_first)) - return call2 (intern ("map-keymap-sorted"), function, keymap); + return call2 (Qmap_keymap_sorted, function, keymap); map_keymap (keymap, map_keymap_call, function, NULL, 1); return Qnil; @@ -1334,7 +1334,7 @@ recognize the default bindings, just as `read-key-sequence' does. */) /* Initialize the unicode case table, if it wasn't already. */ if (NILP (unicode_case_table)) { - unicode_case_table = uniprop_table (intern ("lowercase")); + unicode_case_table = uniprop_table (Qlowercase); /* uni-lowercase.el might be unavailable during bootstrap. */ if (NILP (unicode_case_table)) return found; @@ -2125,7 +2125,7 @@ For an approximate inverse of this, see `kbd'. */) if (STRINGP (list)) { int c = fetch_string_char_advance (list, &i, &i_byte); - if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) + if (!STRING_MULTIBYTE (list) && (c & 0200)) c ^= 0200 | meta_modifier; key = make_fixnum (c); } @@ -3053,7 +3053,7 @@ DESCRIBER is the output function used; nil means use `princ'. */) { specpdl_ref count = SPECPDL_INDEX (); if (NILP (describer)) - describer = intern ("princ"); + describer = Qprinc; specbind (Qstandard_output, Fcurrent_buffer ()); CHECK_VECTOR_OR_CHAR_TABLE (vector); describe_vector (vector, Qnil, describer, describe_vector_princ, 0, @@ -3169,7 +3169,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, Lisp_Object kludge = make_nil_vector (1); if (partial) - suppress = intern ("suppress-keymap"); + suppress = Qsuppress_keymap; /* STOP is a boundary between normal characters (-#x3FFF7F) and 8-bit characters (#x3FFF80-), used below when VECTOR is a @@ -3342,6 +3342,7 @@ syms_of_keymap (void) { DEFSYM (Qkeymap, "keymap"); DEFSYM (Qhelp__describe_map_tree, "help--describe-map-tree"); + DEFSYM (Qmap_keymap_sorted, "map-keymap-sorted"); DEFSYM (Qkeymap_canonicalize, "keymap-canonicalize"); @@ -3485,6 +3486,7 @@ that describe key bindings. That is why the default is nil. */); DEFSYM (Qkey_parse, "key-parse"); DEFSYM (Qkey_valid_p, "key-valid-p"); - DEFSYM (Qnon_key_event, "non-key-event"); + DEFSYM (Qprinc, "princ"); + DEFSYM (Qsuppress_keymap, "suppress-keymap"); } diff --git a/src/lisp.h b/src/lisp.h index f066c876619..010d63e4dd9 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1049,7 +1049,7 @@ enum pvec_type PVEC_SQLITE, /* These should be last, for internal_equal and sxhash_obj. */ - PVEC_COMPILED, + PVEC_CLOSURE, PVEC_CHAR_TABLE, PVEC_SUB_CHAR_TABLE, PVEC_RECORD, @@ -3223,16 +3223,16 @@ XFLOAT_DATA (Lisp_Object f) #define IEEE_FLOATING_POINT (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) -/* Meanings of slots in a Lisp_Compiled: */ +/* Meanings of slots in a Lisp_Closure: */ -enum Lisp_Compiled +enum Lisp_Closure { - COMPILED_ARGLIST = 0, - COMPILED_BYTECODE = 1, - COMPILED_CONSTANTS = 2, - COMPILED_STACK_DEPTH = 3, - COMPILED_DOC_STRING = 4, - COMPILED_INTERACTIVE = 5 + CLOSURE_ARGLIST = 0, + CLOSURE_CODE = 1, + CLOSURE_CONSTANTS = 2, + CLOSURE_STACK_DEPTH = 3, + CLOSURE_DOC_STRING = 4, + CLOSURE_INTERACTIVE = 5 }; /* Flag bits in a character. These also get used in termhooks.h. @@ -3307,9 +3307,9 @@ WINDOW_CONFIGURATIONP (Lisp_Object a) } INLINE bool -COMPILEDP (Lisp_Object a) +CLOSUREP (Lisp_Object a) { - return PSEUDOVECTORP (a, PVEC_COMPILED); + return PSEUDOVECTORP (a, PVEC_CLOSURE); } INLINE bool @@ -4301,7 +4301,8 @@ extern void mark_fns (void); /* Defined in sort.c */ extern void tim_sort (Lisp_Object, Lisp_Object, Lisp_Object *, const ptrdiff_t, - bool); + bool) + ARG_NONNULL ((3)); /* Defined in floatfns.c. */ verify (FLT_RADIX == 2 || FLT_RADIX == 16); @@ -4325,11 +4326,8 @@ extern void init_fringe_once (void); extern int x_bitmap_mask (struct frame *, ptrdiff_t); extern void syms_of_image (void); -#ifdef HAVE_JSON /* Defined in json.c. */ -extern void init_json (void); extern void syms_of_json (void); -#endif /* Defined in insdel.c. */ extern void move_gap_both (ptrdiff_t, ptrdiff_t); @@ -4747,6 +4745,8 @@ extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char *, ptrdiff_t, extern Lisp_Object intern_1 (const char *, ptrdiff_t); extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t); extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object intern_c_multibyte (const char *str, + ptrdiff_t nchars, ptrdiff_t nbytes); extern void init_symbol (Lisp_Object, Lisp_Object); extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t); INLINE void @@ -4934,6 +4934,8 @@ extern void unmark_main_thread (void); /* Defined in editfns.c. */ extern void insert1 (Lisp_Object); +extern void find_field (Lisp_Object, Lisp_Object, Lisp_Object, + ptrdiff_t *, Lisp_Object, ptrdiff_t *); extern void save_excursion_save (union specbinding *); extern void save_excursion_restore (Lisp_Object, Lisp_Object); extern Lisp_Object save_restriction_save (void); @@ -5497,6 +5499,7 @@ extern char *emacs_root_dir (void); #ifdef HAVE_TEXT_CONVERSION /* Defined in textconv.c. */ extern void reset_frame_state (struct frame *); +extern void reset_frame_conversion (struct frame *); extern void report_selected_window_change (struct frame *); extern void report_point_change (struct frame *, struct window *, struct buffer *); @@ -5698,7 +5701,7 @@ safe_free_unbind_to (specpdl_ref count, specpdl_ref sa_count, Lisp_Object val) https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109577 which causes GCC to mistakenly complain about the memory allocation in SAFE_ALLOCA_LISP_EXTRA. */ -#if GNUC_PREREQ (13, 0, 0) && !GNUC_PREREQ (14, 0, 0) +#if __GNUC__ == 13 && __GNUC_MINOR__ < 3 # pragma GCC diagnostic ignored "-Wanalyzer-allocation-size" #endif diff --git a/src/lread.c b/src/lread.c index 1cb941e84fc..c92b2ede932 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1053,13 +1053,19 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, -/* Return true if the lisp code read using READCHARFUN defines a non-nil - `lexical-binding' file variable. After returning, the stream is - positioned following the first line, if it is a comment or #! line, - otherwise nothing is read. */ - -static bool -lisp_file_lexically_bound_p (Lisp_Object readcharfun) +typedef enum { + Cookie_None, /* no cookie */ + Cookie_Dyn, /* explicit dynamic binding */ + Cookie_Lex /* explicit lexical binding */ +} lexical_cookie_t; + +/* Determine if the lisp code read using READCHARFUN defines a + `lexical-binding' file variable return its value. + After returning, the stream is positioned following the first line, + if it is a comment or #! line, otherwise nothing is read. */ + +static lexical_cookie_t +lisp_file_lexical_cookie (Lisp_Object readcharfun) { int ch = READCHAR; @@ -1070,7 +1076,7 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) { UNREAD (ch); UNREAD ('#'); - return 0; + return Cookie_None; } while (ch != '\n' && ch != EOF) ch = READCHAR; @@ -1083,12 +1089,12 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) /* The first line isn't a comment, just give up. */ { UNREAD (ch); - return 0; + return Cookie_None; } else /* Look for an appropriate file-variable in the first line. */ { - bool rv = 0; + lexical_cookie_t rv = Cookie_None; enum { NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX } beg_end_state = NOMINAL; @@ -1170,7 +1176,7 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) if (strcmp (var, "lexical-binding") == 0) /* This is it... */ { - rv = (strcmp (val, "nil") != 0); + rv = strcmp (val, "nil") != 0 ? Cookie_Lex : Cookie_Dyn; break; } } @@ -1785,7 +1791,7 @@ Return t if the file exists and loads successfully. */) } else { - if (lisp_file_lexically_bound_p (Qget_file_char)) + if (lisp_file_lexical_cookie (Qget_file_char) == Cookie_Lex) Fset (Qlexical_binding, Qt); if (! version || version >= 22) @@ -2643,7 +2649,8 @@ settings in the buffer, and if there is no such setting, the buffer will be evaluated without lexical binding. This function preserves the position of point. */) - (Lisp_Object buffer, Lisp_Object printflag, Lisp_Object filename, Lisp_Object unibyte, Lisp_Object do_allow_print) + (Lisp_Object buffer, Lisp_Object printflag, Lisp_Object filename, + Lisp_Object unibyte, Lisp_Object do_allow_print) { specpdl_ref count = SPECPDL_INDEX (); Lisp_Object tem, buf; @@ -2667,7 +2674,8 @@ This function preserves the position of point. */) specbind (Qstandard_output, tem); record_unwind_protect_excursion (); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); - specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); + specbind (Qlexical_binding, + lisp_file_lexical_cookie (buf) == Cookie_Lex ? Qt : Qnil); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); readevalloop (buf, 0, filename, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); @@ -2733,7 +2741,7 @@ STREAM or the value of `standard-input' may be: minibuffer without a stream, as in (read). But is this feature ever used, and if so, why? IOW, will anything break if this feature is removed !? */ - return call1 (intern ("read-minibuffer"), + return call1 (Qread_minibuffer, build_string ("Lisp expression: ")); return read_internal_start (stream, Qnil, Qnil, false); @@ -2761,7 +2769,7 @@ STREAM or the value of `standard-input' may be: stream = Qread_char; if (EQ (stream, Qread_char)) /* FIXME: ?! When is this used !? */ - return call1 (intern ("read-minibuffer"), + return call1 (Qread_minibuffer, build_string ("Lisp expression: ")); return read_internal_start (stream, Qnil, Qnil, true); @@ -3498,52 +3506,59 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun) Lisp_Object *vec = XVECTOR (obj)->contents; ptrdiff_t size = ASIZE (obj); - if (infile && size >= COMPILED_CONSTANTS) + if (infile && size >= CLOSURE_CONSTANTS) { /* Always read 'lazily-loaded' bytecode (generated by the `byte-compile-dynamic' feature prior to Emacs 30) eagerly, to avoid code in the fast path during execution. */ - if (CONSP (vec[COMPILED_BYTECODE]) - && FIXNUMP (XCDR (vec[COMPILED_BYTECODE]))) - vec[COMPILED_BYTECODE] = get_lazy_string (vec[COMPILED_BYTECODE]); + if (CONSP (vec[CLOSURE_CODE]) + && FIXNUMP (XCDR (vec[CLOSURE_CODE]))) + vec[CLOSURE_CODE] = get_lazy_string (vec[CLOSURE_CODE]); /* Lazily-loaded bytecode is represented by the constant slot being nil and the bytecode slot a (lazily loaded) string containing the print representation of (BYTECODE . CONSTANTS). Unpack the pieces by coerceing the string to unibyte and reading the result. */ - if (NILP (vec[COMPILED_CONSTANTS]) && STRINGP (vec[COMPILED_BYTECODE])) + if (NILP (vec[CLOSURE_CONSTANTS]) && STRINGP (vec[CLOSURE_CODE])) { - Lisp_Object enc = vec[COMPILED_BYTECODE]; + Lisp_Object enc = vec[CLOSURE_CODE]; Lisp_Object pair = Fread (Fcons (enc, readcharfun)); if (!CONSP (pair)) invalid_syntax ("Invalid byte-code object", readcharfun); - vec[COMPILED_BYTECODE] = XCAR (pair); - vec[COMPILED_CONSTANTS] = XCDR (pair); + vec[CLOSURE_CODE] = XCAR (pair); + vec[CLOSURE_CONSTANTS] = XCDR (pair); } } - if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1 - && (FIXNUMP (vec[COMPILED_ARGLIST]) - || CONSP (vec[COMPILED_ARGLIST]) - || NILP (vec[COMPILED_ARGLIST])) - && STRINGP (vec[COMPILED_BYTECODE]) - && VECTORP (vec[COMPILED_CONSTANTS]) - && FIXNATP (vec[COMPILED_STACK_DEPTH]))) + if (!(size >= CLOSURE_STACK_DEPTH && size <= CLOSURE_INTERACTIVE + 1 + && (FIXNUMP (vec[CLOSURE_ARGLIST]) + || CONSP (vec[CLOSURE_ARGLIST]) + || NILP (vec[CLOSURE_ARGLIST])) + && ((STRINGP (vec[CLOSURE_CODE]) /* Byte-code function. */ + && VECTORP (vec[CLOSURE_CONSTANTS]) + && size > CLOSURE_STACK_DEPTH + && (FIXNATP (vec[CLOSURE_STACK_DEPTH]))) + || (CONSP (vec[CLOSURE_CODE]) /* Interpreted function. */ + && (CONSP (vec[CLOSURE_CONSTANTS]) + || NILP (vec[CLOSURE_CONSTANTS])))))) invalid_syntax ("Invalid byte-code object", readcharfun); - if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE])) - /* BYTESTR must have been produced by Emacs 20.2 or earlier - because it produced a raw 8-bit string for byte-code and - now such a byte-code string is loaded as multibyte with - raw 8-bit characters converted to multibyte form. - Convert them back to the original unibyte form. */ - vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]); - - /* Bytecode must be immovable. */ - pin_string (vec[COMPILED_BYTECODE]); + if (STRINGP (vec[CLOSURE_CODE])) + { + if (STRING_MULTIBYTE (vec[CLOSURE_CODE])) + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and + now such a byte-code string is loaded as multibyte with + raw 8-bit characters converted to multibyte form. + Convert them back to the original unibyte form. */ + vec[CLOSURE_CODE] = Fstring_as_unibyte (vec[CLOSURE_CODE]); + + /* Bytecode must be immovable. */ + pin_string (vec[CLOSURE_CODE]); + } - XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED); + XSETPVECTYPE (XVECTOR (obj), PVEC_CLOSURE); return obj; } @@ -3954,6 +3969,27 @@ read_stack_reset (intmax_t sp) rdstack.sp = sp; } +#define READ_AND_BUFFER(c) \ + c = READCHAR; \ + if (multibyte) \ + p += CHAR_STRING (c, (unsigned char *) p); \ + else \ + *p++ = c; \ + if (end - p < MAX_MULTIBYTE_LENGTH + 1) \ + { \ + offset = p - read_buffer; \ + read_buffer = grow_read_buffer (read_buffer, offset, \ + &heapbuf, &read_buffer_size, count); \ + p = read_buffer + offset; \ + end = read_buffer + read_buffer_size; \ + } + +#define INVALID_SYNTAX_WITH_BUFFER() \ + { \ + *p = 0; \ + invalid_syntax (read_buffer, readcharfun); \ + } + /* Read a Lisp object. If LOCATE_SYMS is true, symbols are read with position. */ static Lisp_Object @@ -3962,6 +3998,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) char stackbuf[64]; char *read_buffer = stackbuf; ptrdiff_t read_buffer_size = sizeof stackbuf; + ptrdiff_t offset; char *heapbuf = NULL; specpdl_ref base_pdl = SPECPDL_INDEX (); @@ -4063,7 +4100,13 @@ read0 (Lisp_Object readcharfun, bool locate_syms) case '#': { - int ch = READCHAR; + char *p = read_buffer; + char *end = read_buffer + read_buffer_size; + + *p++ = '#'; + int ch; + READ_AND_BUFFER (ch); + switch (ch) { case '\'': @@ -4081,11 +4124,11 @@ read0 (Lisp_Object readcharfun, bool locate_syms) case 's': /* #s(...) -- a record or hash-table */ - ch = READCHAR; + READ_AND_BUFFER (ch); if (ch != '(') { UNREAD (ch); - invalid_syntax ("#s", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } read_stack_push ((struct read_stack_entry) { .type = RE_record, @@ -4098,7 +4141,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) case '^': /* #^[...] -- char-table #^^[...] -- sub-char-table */ - ch = READCHAR; + READ_AND_BUFFER (ch); if (ch == '^') { ch = READCHAR; @@ -4115,7 +4158,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) else { UNREAD (ch); - invalid_syntax ("#^^", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } } else if (ch == '[') @@ -4131,7 +4174,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) else { UNREAD (ch); - invalid_syntax ("#^", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } case '(': @@ -4241,12 +4284,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms) int c; for (;;) { - c = READCHAR; + READ_AND_BUFFER (c); if (c < '0' || c > '9') break; if (ckd_mul (&n, n, 10) || ckd_add (&n, n, c - '0')) - invalid_syntax ("#", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } if (c == 'r' || c == 'R') { @@ -4287,18 +4330,18 @@ read0 (Lisp_Object readcharfun, bool locate_syms) = XHASH_TABLE (read_objects_map); ptrdiff_t i = hash_lookup (h, make_fixnum (n)); if (i < 0) - invalid_syntax ("#", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); obj = HASH_VALUE (h, i); break; } else - invalid_syntax ("#", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } else - invalid_syntax ("#", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } else - invalid_syntax ("#", readcharfun); + INVALID_SYNTAX_WITH_BUFFER (); } break; } @@ -4678,7 +4721,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree) if (BOOL_VECTOR_P (subtree)) return subtree; /* No sub-objects anyway. */ else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree) - || COMPILEDP (subtree) || HASH_TABLE_P (subtree) + || CLOSUREP (subtree) || HASH_TABLE_P (subtree) || RECORDP (subtree)) length = PVSIZE (subtree); else if (VECTORP (subtree)) @@ -4993,6 +5036,18 @@ intern_c_string_1 (const char *str, ptrdiff_t len) return tem; } +/* Intern STR of NBYTES bytes and NCHARS characters in the default obarray. */ +Lisp_Object +intern_c_multibyte (const char *str, ptrdiff_t nchars, ptrdiff_t nbytes) +{ + Lisp_Object obarray = check_obarray (Vobarray); + Lisp_Object sym = oblookup (obarray, str, nchars, nbytes); + if (BARE_SYMBOL_P (sym)) + return sym; + return intern_driver (make_multibyte_string (str, nchars, nbytes), + obarray, sym); +} + static void define_symbol (Lisp_Object sym, char const *str) { @@ -6163,4 +6218,5 @@ Only valid during macro-expansion. Internal use only. */); DEFSYM (Qinternal_macroexpand_for_load, "internal-macroexpand-for-load"); + DEFSYM (Qread_minibuffer, "read-minibuffer"); } diff --git a/src/marker.c b/src/marker.c index 2abc951fc76..f016bf9c088 100644 --- a/src/marker.c +++ b/src/marker.c @@ -21,7 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> /* Work around GCC bug 113253. */ -#if __GNUC__ == 13 +#if __GNUC__ == 13 && __GNUC_MINOR__ < 3 # pragma GCC diagnostic ignored "-Wanalyzer-deref-before-check" #endif diff --git a/src/minibuf.c b/src/minibuf.c index 51816133fb2..9c1c86680d4 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -494,12 +494,11 @@ confirm the aborting of the current minibuffer and all contained ones. */) to abort any extra non-minibuffer recursive edits. Thus, the number of recursive edits we have to abort equals the number of minibuffers we have to abort. */ - CALLN (Ffuncall, intern ("minibuffer-quit-recursive-edit"), - array[1]); + call1 (Qminibuffer_quit_recursive_edit, array[1]); } } else - CALLN (Ffuncall, intern ("minibuffer-quit-recursive-edit")); + call0 (Qminibuffer_quit_recursive_edit); return Qnil; } @@ -1367,6 +1366,20 @@ and some related functions, which use zero-indexing for POSITION. */) if (NILP (histpos)) XSETFASTINT (histpos, 0); +#ifdef HAVE_TEXT_CONVERSION + /* If overriding-text-conversion-style is set, assume that it was + changed prior to this call and force text conversion to be reset, + since redisplay might conclude that the value was retained + unmodified from a previous call to Fread_from_minibuffer as the + selected window will not have changed. */ + if (!EQ (Voverriding_text_conversion_style, Qlambda) + /* Separate minibuffer frames are not material here, since they + will already be selected if the situation that this is meant to + prevent is possible. */ + && FRAME_WINDOW_P (SELECTED_FRAME ())) + reset_frame_conversion (SELECTED_FRAME ()); +#endif /* HAVE_TEXT_CONVERSION */ + val = read_minibuf (keymap, initial_contents, prompt, !NILP (read), histvar, histpos, default_value, @@ -1525,12 +1538,12 @@ function, instead of the usual behavior. */) STRING_MULTIBYTE (prompt)); } - prompt = CALLN (Ffuncall, intern("format-prompt"), + prompt = CALLN (Ffuncall, Qformat_prompt, prompt, CONSP (def) ? XCAR (def) : def); } - result = Fcompleting_read (prompt, intern ("internal-complete-buffer"), + result = Fcompleting_read (prompt, Qinternal_complete_buffer, predicate, require_match, Qnil, Qbuffer_name_history, def, Qnil); } @@ -2018,7 +2031,7 @@ See also `completing-read-function'. */) (Lisp_Object prompt, Lisp_Object collection, Lisp_Object predicate, Lisp_Object require_match, Lisp_Object initial_input, Lisp_Object hist, Lisp_Object def, Lisp_Object inherit_input_method) { return CALLN (Ffuncall, - Fsymbol_value (intern ("completing-read-function")), + Fsymbol_value (Qcompleting_read_function), prompt, collection, predicate, require_match, initial_input, hist, def, inherit_input_method); } @@ -2517,4 +2530,8 @@ showing the *Completions* buffer, if any. */); defsubr (&Stest_completion); defsubr (&Sassoc_string); defsubr (&Scompleting_read); + DEFSYM (Qminibuffer_quit_recursive_edit, "minibuffer-quit-recursive-edit"); + DEFSYM (Qinternal_complete_buffer, "internal-complete-buffer"); + DEFSYM (Qcompleting_read_function, "completing-read-function"); + DEFSYM (Qformat_prompt, "format-prompt"); } diff --git a/src/msdos.c b/src/msdos.c index 7e78c35027e..e9faa48fa70 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -3070,12 +3070,12 @@ XMenuActivate (Display *foo, XMenu *menu, int *pane, int *selidx, state = alloca (menu->panecount * sizeof (struct IT_menu_state)); screensize = screen_size * 2; faces[0] - = lookup_derived_face (NULL, sf, intern ("msdos-menu-passive-face"), + = lookup_derived_face (NULL, sf, Qmsdos_menu_passive_face, DEFAULT_FACE_ID, 1); faces[1] - = lookup_derived_face (NULL, sf, intern ("msdos-menu-active-face"), + = lookup_derived_face (NULL, sf, Qmsdos_menu_active_face, DEFAULT_FACE_ID, 1); - selectface = intern ("msdos-menu-select-face"); + selectface = Qmsdos_menu_select_face; faces[2] = lookup_derived_face (NULL, sf, selectface, faces[0], 1); faces[3] = lookup_derived_face (NULL, sf, selectface, @@ -3740,7 +3740,7 @@ run_msdos_command (char **argv, const char *working_dir, *pl = '\0'; cmd = Ffile_name_nondirectory (build_string (lowcase_argv0)); - msshell = !NILP (Fmember (cmd, Fsymbol_value (intern ("msdos-shells")))) + msshell = !NILP (Fmember (cmd, Fsymbol_value (Qmsdos_shells))) && !strcmp ("-c", argv[1]); if (msshell) { @@ -4324,6 +4324,11 @@ This variable is used only by MS-DOS terminals. */); defsubr (&Smsdos_downcase_filename); defsubr (&Smsdos_remember_default_colors); defsubr (&Smsdos_set_mouse_buttons); + + DEFSYM (Qmsdos_menu_passive_face, "msdos-menu-passive-face"); + DEFSYM (Qmsdos_menu_active_face, "msdos-menu-active-face"); + DEFSYM (Qmsdos_menu_select_face, "msdos-menu-select-face"); + DEFSYM (Qmsdos_shells, "msdos-shells"); } #endif /* MSDOS */ diff --git a/src/nsfns.m b/src/nsfns.m index c521140bd68..b08d053610f 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -2046,12 +2046,12 @@ DEFUN ("x-display-backing-store", Fx_display_backing_store, switch ([ns_get_window (terminal) backingType]) { case NSBackingStoreBuffered: - return intern ("buffered"); + return Qbuffered; #if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: - return intern ("retained"); + return Qretained; case NSBackingStoreNonretained: - return intern ("non-retained"); + return Qnon_retained; #endif default: error ("Strange value for backingType parameter of frame"); @@ -2071,19 +2071,19 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class, depth = [[[NSScreen screens] objectAtIndex:0] depth]; if ( depth == NSBestDepth (NSCalibratedWhiteColorSpace, 2, 2, YES, NULL)) - return intern ("static-gray"); + return Qstatic_gray; else if (depth == NSBestDepth (NSCalibratedWhiteColorSpace, 8, 8, YES, NULL)) - return intern ("gray-scale"); + return Qgray_scale; else if ( depth == NSBestDepth (NSCalibratedRGBColorSpace, 8, 8, YES, NULL)) - return intern ("pseudo-color"); + return Qpseudo_color; else if ( depth == NSBestDepth (NSCalibratedRGBColorSpace, 4, 12, NO, NULL)) - return intern ("true-color"); + return Qtrue_color; else if ( depth == NSBestDepth (NSCalibratedRGBColorSpace, 8, 24, NO, NULL)) - return intern ("direct-color"); + return Qdirect_color; else /* Color management as far as we do it is really handled by Nextstep itself anyway. */ - return intern ("direct-color"); + return Qdirect_color; } @@ -2183,13 +2183,13 @@ is layered in front of the windows of other applications. */) (Lisp_Object on) { check_window_system (NULL); - if (EQ (on, intern ("activate"))) + if (EQ (on, Qactivate)) { [NSApp unhide: NSApp]; [NSApp activateIgnoringOtherApps: YES]; } #if GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION >= 27 - else if (EQ (on, intern ("activate-front"))) + else if (EQ (on, Qactivate_front)) { [NSApp unhide: NSApp]; [[NSRunningApplication currentApplication] @@ -2530,7 +2530,7 @@ DEFUN ("system-move-file-to-trash", Fsystem_move_file_to_trash, if (!NILP (Ffile_directory_p (filename)) && NILP (Ffile_symlink_p (filename))) { - operation = intern ("delete-directory"); + operation = Qdelete_directory; filename = Fdirectory_file_name (filename); } @@ -3149,7 +3149,7 @@ ns_create_tip_frame (struct ns_display_info *dpyinfo, Lisp_Object parms) /* Set the `display-type' frame parameter before setting up faces. */ { - Lisp_Object disptype = intern ("color"); + Lisp_Object disptype = Qcolor; if (NILP (Fframe_parameter (frame, Qdisplay_type))) { @@ -3208,7 +3208,7 @@ x_hide_tip (bool delete) { if (!NILP (tip_timer)) { - call1 (intern ("cancel-timer"), tip_timer); + call1 (Qcancel_timer, tip_timer); tip_timer = Qnil; } @@ -3359,7 +3359,7 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, tip_f = XFRAME (tip_frame); if (!NILP (tip_timer)) { - call1 (intern ("cancel-timer"), tip_timer); + call1 (Qcancel_timer, tip_timer); tip_timer = Qnil; } @@ -3406,12 +3406,12 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, break; } else - tip_last_parms = - call2 (intern ("assq-delete-all"), parm, tip_last_parms); + tip_last_parms + = call2 (Qassq_delete_all, parm, tip_last_parms); } else - tip_last_parms = - call2 (intern ("assq-delete-all"), parm, tip_last_parms); + tip_last_parms + = call2 (Qassq_delete_all, parm, tip_last_parms); } /* Now check if every parameter in what is left of @@ -3573,8 +3573,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, start_timer: /* Let the tip disappear after timeout seconds. */ - tip_timer = call3 (intern ("run-at-time"), timeout, Qnil, - intern ("x-hide-tip")); + tip_timer = call3 (Qrun_at_time, timeout, Qnil, + Qx_hide_tip); } return unbind_to (count, Qnil); @@ -4076,4 +4076,20 @@ The default value is t. */); as_script = Qnil; staticpro (&as_script); as_result = 0; + + DEFSYM (Qbuffered, "buffered"); + DEFSYM (Qretained, "retained"); + DEFSYM (Qnon_retained, "non-retained"); + DEFSYM (Qstatic_gray, "static-gray"); + DEFSYM (Qgray_scale, "gray-scale"); + DEFSYM (Qpseudo_color, "pseudo-color"); + DEFSYM (Qtrue_color, "true-color"); + DEFSYM (Qdirect_color, "direct-color"); + DEFSYM (Qactivate, "activate"); + DEFSYM (Qactivate_front, "activate-front"); + DEFSYM (Qcolor, "color"); + DEFSYM (Qcancel_timer, "cancel-timer"); + DEFSYM (Qassq_delete_all, "assq-delete-all"); + DEFSYM (Qrun_at_time, "run-at-time"); + DEFSYM (Qx_hide_tip, "x-hide-tip"); } diff --git a/src/nsfont.m b/src/nsfont.m index 4e1d85a5c4a..ddbaea11967 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -337,8 +337,8 @@ ns_spec_to_descriptor (Lisp_Object font_spec) if (EQ (tem, Qitalic) || EQ (tem, Qoblique)) [tdict setObject: [NSNumber numberWithFloat: 1.0] forKey: NSFontSlantTrait]; - else if (EQ (tem, intern ("reverse-italic")) - || EQ (tem, intern ("reverse-oblique"))) + else if (EQ (tem, Qreverse_italic) + || EQ (tem, Qreverse_oblique)) [tdict setObject: [NSNumber numberWithFloat: -1.0] forKey: NSFontSlantTrait]; else @@ -451,7 +451,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, data.slant == GS_FONT_SLANT_ITALIC ? Qitalic : (data.slant == GS_FONT_SLANT_REVERSE_ITALIC - ? intern ("reverse-italic") : Qnormal)); + ? Qreverse_italic : Qnormal)); } else FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, Qnormal); @@ -461,7 +461,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, data.width == GS_FONT_WIDTH_CONDENSED ? Qcondensed : (data.width == GS_FONT_WIDTH_EXPANDED - ? intern ("expanded") : Qnormal)); + ? Qexpanded : Qnormal)); } else FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, Qnormal); @@ -1180,21 +1180,12 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, { NSRect br = NSMakeRect (x, y - FONT_BASE (s->font), s->width, FONT_HEIGHT (s->font)); - - if (!s->face->stipple) - { - if (s->hl != DRAW_CURSOR) - [(NS_FACE_BACKGROUND (face) != 0 - ? [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] - : FRAME_BACKGROUND_COLOR (s->f)) set]; - else - [FRAME_CURSOR_COLOR (s->f) set]; - } + if (s->hl != DRAW_CURSOR) + [(NS_FACE_BACKGROUND (face) != 0 + ? [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] + : FRAME_BACKGROUND_COLOR (s->f)) set]; else - { - struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f); - [[dpyinfo->bitmaps[face->stipple-1].img stippleMask] set]; - } + [FRAME_CURSOR_COLOR (s->f) set]; NSRectFill (br); } @@ -1753,7 +1744,6 @@ void syms_of_nsfont (void) { DEFSYM (Qcondensed, "condensed"); - DEFSYM (Qexpanded, "expanded"); DEFSYM (Qmedium, "medium"); DEFVAR_LISP ("ns-reg-to-script", Vns_reg_to_script, @@ -1761,6 +1751,11 @@ syms_of_nsfont (void) Vns_reg_to_script = Qnil; pdumper_do_now_and_after_load (syms_of_nsfont_for_pdumper); + + /* Font slant styles. */ + DEFSYM (Qreverse_italic, "reverse-italic"); + DEFSYM (Qreverse_oblique, "reverse-oblique"); + DEFSYM (Qexpanded, "expanded"); } static void diff --git a/src/nsterm.m b/src/nsterm.m index faf9324402b..f26cdb17903 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3310,7 +3310,66 @@ ns_draw_underwave (struct glyph_string *s, EmacsCGFloat width, EmacsCGFloat x) [[NSGraphicsContext currentContext] restoreGraphicsState]; } +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto + the focused frame at a vertical offset of OFFSET from the position of + the glyph string S, with each segment SEGMENT pixels in length. */ +static void +ns_draw_dash (struct glyph_string *s, int width, int segment, + int offset, int thickness) +{ + CGFloat pattern[2], y_center = s->ybase + offset + thickness / 2.0; + NSBezierPath *path = [[NSBezierPath alloc] init]; + + pattern[0] = segment; + pattern[1] = segment; + + [path setLineDash: pattern count: 2 phase: (CGFloat) s->x]; + [path setLineWidth: thickness]; + [path moveToPoint: NSMakePoint (s->x, y_center)]; + [path lineToPoint: NSMakePoint (s->x + width, y_center)]; + [path stroke]; + [path release]; +} + +/* Draw an underline of STYLE onto the focused frame at an offset of + POSITION from the baseline of the glyph string S, S->WIDTH in length, + and THICKNESS in height. */ + +static void +ns_fill_underline (struct glyph_string *s, enum face_underline_type style, + int position, int thickness) +{ + int segment; + NSRect rect; + + segment = thickness * 3; + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + rect = NSMakeRect (s->x, s->ybase + position, s->width, thickness); + NSRectFill (rect); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + ns_draw_dash (s, s->width, segment, position, thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} static void ns_draw_text_decoration (struct glyph_string *s, struct face *face, @@ -3330,22 +3389,21 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, /* Do underline. */ if (face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (!face->underline_defaulted_p) [[NSColor colorWithUnsignedLong:face->underline_color] set]; ns_draw_underwave (s, width, x); } - else if (s->face->underline == FACE_UNDER_LINE) + else if (face->underline >= FACE_UNDERLINE_SINGLE) { - - NSRect r; unsigned long thickness, position; /* If the prev was underlined, match its appearance. */ if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && s->prev->underline_thickness > 0 && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) @@ -3411,12 +3469,22 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, s->underline_thickness = thickness; s->underline_position = position; - r = NSMakeRect (x, s->ybase + position, width, thickness); - if (!face->underline_defaulted_p) [[NSColor colorWithUnsignedLong:face->underline_color] set]; - NSRectFill (r); + ns_fill_underline (s, s->face->underline, position, + thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + ns_fill_underline (s, s->face->underline, position, + thickness); + } } } /* Do overline. We follow other terms in using a thickness of 1 @@ -3740,7 +3808,6 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) } } - static void ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p) /* -------------------------------------------------------------------------- @@ -3748,45 +3815,47 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p) certain cases. Others are left to the text rendering routine. -------------------------------------------------------------------------- */ { + struct face *face = s->face; + NSRect r; + NSTRACE ("ns_maybe_dumpglyphs_background"); - if (!s->background_filled_p/* || s->hl == DRAW_MOUSE_FACE*/) + if (!s->background_filled_p) { int box_line_width = max (s->face->box_horizontal_line_width, 0); - if (FONT_HEIGHT (s->font) < s->height - 2 * box_line_width - /* When xdisp.c ignores FONT_HEIGHT, we cannot trust font - dimensions, since the actual glyphs might be much - smaller. So in that case we always clear the rectangle - with background color. */ - || FONT_TOO_HIGH (s->font) - || s->font_not_found_p || s->extends_to_end_of_line_p || force_p) + if (s->stippled_p) { - struct face *face = s->face; - if (!face->stipple) - { - if (s->hl != DRAW_CURSOR) - [(NS_FACE_BACKGROUND (face) != 0 - ? [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] - : FRAME_BACKGROUND_COLOR (s->f)) set]; - else if (face && (NS_FACE_BACKGROUND (face) - == [(NSColor *) FRAME_CURSOR_COLOR (s->f) - unsignedLong])) - [[NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)] set]; - else - [FRAME_CURSOR_COLOR (s->f) set]; - } - else - { - struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f); - [[dpyinfo->bitmaps[face->stipple-1].img stippleMask] set]; - } + struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f); + [[dpyinfo->bitmaps[face->stipple-1].img stippleMask] set]; + goto fill; + } + else if (FONT_HEIGHT (s->font) < s->height - 2 * box_line_width + /* When xdisp.c ignores FONT_HEIGHT, we cannot trust font + dimensions, since the actual glyphs might be much + smaller. So in that case we always clear the + rectangle with background color. */ + || FONT_TOO_HIGH (s->font) + || s->font_not_found_p + || s->extends_to_end_of_line_p + || force_p) + { + if (s->hl != DRAW_CURSOR) + [(NS_FACE_BACKGROUND (face) != 0 + ? [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] + : FRAME_BACKGROUND_COLOR (s->f)) set]; + else if (face && (NS_FACE_BACKGROUND (face) + == [(NSColor *) FRAME_CURSOR_COLOR (s->f) + unsignedLong])) + [[NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)] set]; + else + [FRAME_CURSOR_COLOR (s->f) set]; - NSRect r = NSMakeRect (s->x, s->y + box_line_width, - s->background_width, - s->height - 2 * box_line_width); + fill: + r = NSMakeRect (s->x, s->y + box_line_width, + s->background_width, + s->height - 2 * box_line_width); NSRectFill (r); - s->background_filled_p = 1; } } @@ -4015,8 +4084,7 @@ ns_draw_stretch_glyph_string (struct glyph_string *s) struct face *face; NSColor *fg_color; - if (s->hl == DRAW_CURSOR - && !x_stretch_cursor_p) + if (s->hl == DRAW_CURSOR && !x_stretch_cursor_p) { /* If `x-stretch-cursor' is nil, don't draw a block cursor as wide as the stretch glyph. */ @@ -4102,8 +4170,13 @@ ns_draw_stretch_glyph_string (struct glyph_string *s) if (background_width > 0) { + struct ns_display_info *dpyinfo; + + dpyinfo = FRAME_DISPLAY_INFO (s->f); if (s->hl == DRAW_CURSOR) [FRAME_CURSOR_COLOR (s->f) set]; + else if (s->stippled_p) + [[dpyinfo->bitmaps[s->face->stipple - 1].img stippleMask] set]; else [[NSColor colorWithUnsignedLong: s->face->background] set]; @@ -4321,6 +4394,45 @@ ns_draw_glyphless_glyph_string_foreground (struct glyph_string *s) s->char2b = NULL; } +/* Transfer glyph string parameters from S's face to S itself. + Set S->stipple_p as appropriate, taking the draw type into + account. */ + +static void +ns_set_glyph_string_gc (struct glyph_string *s) +{ + prepare_face_for_display (s->f, s->face); + + if (s->hl == DRAW_NORMAL_TEXT) + { + /* s->gc = s->face->gc; */ + s->stippled_p = s->face->stipple != 0; + } + else if (s->hl == DRAW_INVERSE_VIDEO) + { + /* x_set_mode_line_face_gc (s); */ + s->stippled_p = s->face->stipple != 0; + } + else if (s->hl == DRAW_CURSOR) + { + /* x_set_cursor_gc (s); */ + s->stippled_p = false; + } + else if (s->hl == DRAW_MOUSE_FACE) + { + /* x_set_mouse_face_gc (s); */ + s->stippled_p = s->face->stipple != 0; + } + else if (s->hl == DRAW_IMAGE_RAISED + || s->hl == DRAW_IMAGE_SUNKEN) + { + /* s->gc = s->face->gc; */ + s->stippled_p = s->face->stipple != 0; + } + else + emacs_abort (); +} + static void ns_draw_glyph_string (struct glyph_string *s) /* -------------------------------------------------------------------------- @@ -4346,6 +4458,7 @@ ns_draw_glyph_string (struct glyph_string *s) width += next->width, next = next->next) if (next->first_glyph->type != IMAGE_GLYPH) { + ns_set_glyph_string_gc (next); n = ns_get_glyph_string_clip_rect (s->next, r); ns_focus (s->f, r, n); if (next->first_glyph->type != STRETCH_GLYPH) @@ -4357,6 +4470,8 @@ ns_draw_glyph_string (struct glyph_string *s) } } + ns_set_glyph_string_gc (s); + if (!s->for_overlaps && s->face->box != FACE_NO_BOX && (s->first_glyph->type == CHAR_GLYPH || s->first_glyph->type == COMPOSITE_GLYPH)) diff --git a/src/pdumper.c b/src/pdumper.c index ac8bf6f31f4..3806953f2c2 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3050,7 +3050,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_2D583AC566 +#if CHECK_STRUCTS && !defined HASH_pvec_type_99104541E2 # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); @@ -3068,7 +3068,7 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object(ctx, lv, "font"); FALLTHROUGH; case PVEC_NORMAL_VECTOR: - case PVEC_COMPILED: + case PVEC_CLOSURE: case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_RECORD: @@ -4156,7 +4156,7 @@ types. */) /* Bind `command-line-processed' to nil before dumping, so that the dumped Emacs will process its command line and set up to work with X windows if appropriate. */ - Lisp_Object symbol = intern ("command-line-processed"); + Lisp_Object symbol = Qcommand_line_processed; specbind (symbol, Qnil); CHECK_STRING (filename); diff --git a/src/pgtkfns.c b/src/pgtkfns.c index f43eed6ad23..6a8efb6d0bf 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -2148,7 +2148,7 @@ If omitted or nil, that stands for the selected frame's display. On PGTK, always return true-color. */) (Lisp_Object terminal) { - return intern ("true-color"); + return Qtrue_color; } @@ -2844,7 +2844,7 @@ x_create_tip_frame (struct pgtk_display_info *dpyinfo, Lisp_Object parms, struct { Lisp_Object disptype; - disptype = intern ("color"); + disptype = Qcolor; if (NILP (Fframe_parameter (frame, Qdisplay_type))) { @@ -3391,8 +3391,7 @@ Text larger than the specified size is clipped. */) start_timer: /* Let the tip disappear after timeout seconds. */ - tip_timer = call3 (intern ("run-at-time"), timeout, Qnil, - intern ("x-hide-tip")); + tip_timer = call3 (Qrun_at_time, timeout, Qnil, Qx_hide_tip); return unbind_to (count, Qnil); } @@ -3967,4 +3966,8 @@ syms_of_pgtkfns (void) DEFSYM (Qlandscape, "landscape"); DEFSYM (Qreverse_portrait, "reverse-portrait"); DEFSYM (Qreverse_landscape, "reverse-landscape"); + DEFSYM (Qtrue_color, "true-color"); + DEFSYM (Qcolor, "color"); + DEFSYM (Qrun_at_time, "run-at-time"); + DEFSYM (Qx_hide_tip, "x-hide-tip"); } diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 1ec6bfcda4e..8d9a47b932f 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -53,7 +53,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "termhooks.h" #include "termopts.h" #include "termchar.h" -#include "emacs-icon.h" #include "menu.h" #include "window.h" #include "keyboard.h" @@ -1239,7 +1238,7 @@ pgtk_set_glyph_string_gc (struct glyph_string *s) line or menu if we don't have X toolkit support. */ static void -pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) +pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t *cr) { XRectangle r[2]; int n = get_glyph_string_clip_rects (s, r, 2); @@ -1260,7 +1259,7 @@ pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) static void pgtk_set_glyph_string_clipping_exactly (struct glyph_string *src, - struct glyph_string *dst, cairo_t * cr) + struct glyph_string *dst, cairo_t *cr) { dst->clip[0].x = src->x; dst->clip[0].y = src->y; @@ -2434,6 +2433,73 @@ pgtk_draw_stretch_glyph_string (struct glyph_string *s) s->background_filled_p = true; } + +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto F + at a vertical offset of OFFSET from the position of the glyph string + S, with each segment SEGMENT pixels in length. */ + +static void +pgtk_draw_dash (struct frame *f, struct glyph_string *s, + unsigned long foreground, int width, + char segment, int offset, int thickness) +{ + cairo_t *cr; + double cr_segment, y_center; + + cr = pgtk_begin_cr_clip (s->f); + pgtk_set_cr_source_with_color (f, foreground, false); + cr_segment = (double) segment; + y_center = s->ybase + offset + (thickness / 2.0); + + cairo_set_dash (cr, &cr_segment, 1, s->x); + cairo_set_line_width (cr, thickness); + cairo_move_to (cr, s->x, y_center); + cairo_line_to (cr, s->x + width, y_center); + cairo_stroke (cr); + pgtk_end_cr_clip (f); +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S in the color provided by FOREGROUND, + DECORATION_WIDTH in length, and THICKNESS in height. */ + +static void +pgtk_fill_underline (struct frame *f, struct glyph_string *s, + unsigned long foreground, + enum face_underline_type style, int position, + int decoration_width, int thickness) +{ + int segment; + + segment = thickness * 3; + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + pgtk_fill_rectangle (f, foreground, s->x, s->ybase + position, + decoration_width, thickness, false); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + pgtk_draw_dash (f, s, foreground, decoration_width, segment, + position, thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} + static void pgtk_draw_glyph_string (struct glyph_string *s) { @@ -2546,20 +2612,21 @@ pgtk_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (s->face->underline_defaulted_p) pgtk_draw_underwave (s, s->xgcv.foreground); else pgtk_draw_underwave (s, s->face->underline_color); } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; + unsigned long foreground; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -2615,16 +2682,24 @@ pgtk_draw_glyph_string (struct glyph_string *s) thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; s->underline_position = position; - y = s->ybase + position; + if (s->face->underline_defaulted_p) - pgtk_fill_rectangle (s->f, s->xgcv.foreground, - s->x, y, s->width, thickness, - false); + foreground = s->xgcv.foreground; else + foreground = s->face->underline_color; + + pgtk_fill_underline (s->f, s, foreground, s->face->underline, + position, s->width, thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { - pgtk_fill_rectangle (s->f, s->face->underline_color, - s->x, y, s->width, thickness, - false); + /* Compute the position of the second underline. */ + position = position - thickness - 1; + pgtk_fill_underline (s->f, s, foreground, s->face->underline, + position, s->width, thickness); } } } @@ -7107,6 +7182,9 @@ syms_of_pgtkterm (void) DEFSYM (Qsuper, "super"); DEFSYM (Qcontrol, "control"); DEFSYM (QUTF8_STRING, "UTF8_STRING"); + /* Referenced in gtkutil.c. */ + DEFSYM (Qtheme_name, "theme-name"); + DEFSYM (Qfile_name_sans_extension, "file-name-sans-extension"); DEFSYM (Qfile, "file"); DEFSYM (Qurl, "url"); @@ -7124,7 +7202,6 @@ syms_of_pgtkterm (void) DEFSYM (Qlink, "link"); DEFSYM (Qprivate, "private"); - Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier)); Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier)); Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier)); @@ -7404,5 +7481,5 @@ pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type) unbind_to (count, Qnil); - return CALLN (Fapply, intern ("concat"), Fnreverse (acc)); + return CALLN (Fapply, Qconcat, Fnreverse (acc)); } diff --git a/src/print.c b/src/print.c index 76c577ec800..612d63b7e94 100644 --- a/src/print.c +++ b/src/print.c @@ -1299,7 +1299,7 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) (STRINGP (obj) \ || CONSP (obj) \ || (VECTORLIKEP (obj) \ - && (VECTORP (obj) || COMPILEDP (obj) \ + && (VECTORP (obj) || CLOSUREP (obj) \ || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \ || HASH_TABLE_P (obj) || FONTP (obj) \ || RECORDP (obj))) \ @@ -2091,7 +2091,7 @@ print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun, /* Types handled earlier. */ case PVEC_NORMAL_VECTOR: case PVEC_RECORD: - case PVEC_COMPILED: + case PVEC_CLOSURE: case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_HASH_TABLE: @@ -2559,7 +2559,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj), printcharfun); goto next_obj; - case PVEC_COMPILED: + case PVEC_CLOSURE: print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj), printcharfun); goto next_obj; @@ -2859,6 +2859,7 @@ decimal point. 0 is not allowed with `e' or `g'. A value of nil means to use the shortest notation that represents the number without losing information. */); Vfloat_output_format = Qnil; + DEFSYM (Qfloat_output_format, "float-output-format"); DEFVAR_BOOL ("print-integers-as-characters", print_integers_as_characters, doc: /* Non-nil means integers are printed using characters syntax. diff --git a/src/process.c b/src/process.c index 6b8b483cdf7..50d1968200d 100644 --- a/src/process.c +++ b/src/process.c @@ -2114,7 +2114,7 @@ dissociate_controlling_tty (void) child that has not execed. I wonder: would just ioctl (fd, TIOCNOTTY, 0) work here, for some fd that the caller already has? */ - int ttyfd = emacs_open (DEV_TTY, O_RDWR, 0); + int ttyfd = emacs_open (dev_tty, O_RDWR, 0); if (0 <= ttyfd) { ioctl (ttyfd, TIOCNOTTY, 0); diff --git a/src/profiler.c b/src/profiler.c index 5a6a8b48f6b..6e1dc46abd3 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -170,9 +170,7 @@ trace_hash (Lisp_Object *trace, int depth) { Lisp_Object f = trace[i]; EMACS_UINT hash1 - = (COMPILEDP (f) ? XHASH (AREF (f, COMPILED_BYTECODE)) - : (CONSP (f) && CONSP (XCDR (f)) && BASE_EQ (Qclosure, XCAR (f))) - ? XHASH (XCDR (XCDR (f))) : XHASH (f)); + = (CLOSUREP (f) ? XHASH (AREF (f, CLOSURE_CODE)) : XHASH (f)); hash = sxhash_combine (hash, hash1); } return hash; @@ -675,12 +673,8 @@ the same lambda expression, or are really unrelated function. */) bool res; if (EQ (f1, f2)) res = true; - else if (COMPILEDP (f1) && COMPILEDP (f2)) - res = EQ (AREF (f1, COMPILED_BYTECODE), AREF (f2, COMPILED_BYTECODE)); - else if (CONSP (f1) && CONSP (f2) && CONSP (XCDR (f1)) && CONSP (XCDR (f2)) - && EQ (Qclosure, XCAR (f1)) - && EQ (Qclosure, XCAR (f2))) - res = EQ (XCDR (XCDR (f1)), XCDR (XCDR (f2))); + else if (CLOSUREP (f1) && CLOSUREP (f2)) + res = EQ (AREF (f1, CLOSURE_CODE), AREF (f2, CLOSURE_CODE)); else res = false; return res ? Qt : Qnil; diff --git a/src/search.c b/src/search.c index f2d1f1f5449..b092d5b7fef 100644 --- a/src/search.c +++ b/src/search.c @@ -2759,6 +2759,7 @@ since only regular expressions have distinguished subexpressions. */) /* Replace the old text with the new in the cleanest possible way. */ replace_range (sub_start, sub_end, newtext, 1, 0, 1, true, true); + signal_after_change (sub_start, sub_end - sub_start, SCHARS (newtext)); if (case_action == all_caps) Fupcase_region (make_fixnum (search_regs.start[sub]), @@ -2783,7 +2784,6 @@ since only regular expressions have distinguished subexpressions. */) /* Now move point "officially" to the end of the inserted replacement. */ move_if_not_intangible (newpoint); - signal_after_change (sub_start, sub_end - sub_start, SCHARS (newtext)); update_compositions (sub_start, newpoint, CHECK_BORDER); return Qnil; diff --git a/src/sfnt.c b/src/sfnt.c index 8598b052044..d909fba7677 100644 --- a/src/sfnt.c +++ b/src/sfnt.c @@ -16650,10 +16650,10 @@ sfnt_read_OS_2_table (int fd, struct sfnt_offset_subtable *subtable) OS_2 = xmalloc (sizeof *OS_2); - /* Read data up to the end of `panose'. */ + /* Read data into the structure. */ - wanted = SFNT_ENDOF (struct sfnt_OS_2_table, panose, - unsigned char[10]); + wanted = SFNT_ENDOF (struct sfnt_OS_2_table, fs_last_char_index, + uint16_t); rc = read (fd, OS_2, wanted); if (rc == -1 || rc != wanted) @@ -16680,20 +16680,6 @@ sfnt_read_OS_2_table (int fd, struct sfnt_offset_subtable *subtable) sfnt_swap16 (&OS_2->y_strikeout_size); sfnt_swap16 (&OS_2->y_strikeout_position); sfnt_swap16 (&OS_2->s_family_class); - - /* Read fields between ul_unicode_range and fs_last_char_index. */ - wanted = (SFNT_ENDOF (struct sfnt_OS_2_table, fs_last_char_index, - uint16_t) - - offsetof (struct sfnt_OS_2_table, ul_unicode_range)); - rc = read (fd, &OS_2->ul_unicode_range, wanted); - - if (rc == -1 || rc != wanted) - { - xfree (OS_2); - return NULL; - } - - /* Swap the remainder and return the table. */ sfnt_swap32 (&OS_2->ul_unicode_range[0]); sfnt_swap32 (&OS_2->ul_unicode_range[1]); sfnt_swap32 (&OS_2->ul_unicode_range[2]); diff --git a/src/sfnt.h b/src/sfnt.h index 444b1dfe427..ecc3876b394 100644 --- a/src/sfnt.h +++ b/src/sfnt.h @@ -1395,8 +1395,6 @@ struct sfnt_OS_2_table /* Microsoft ``panose'' classification. */ unsigned char panose[10]; - /* Alignment boundary! */ - /* Unicode range specification. */ uint32_t ul_unicode_range[4]; diff --git a/src/sfntfont-android.c b/src/sfntfont-android.c index 1ed394b9458..b90ca857dd4 100644 --- a/src/sfntfont-android.c +++ b/src/sfntfont-android.c @@ -503,6 +503,10 @@ sfntfont_android_put_glyphs (struct glyph_string *s, int from, if (with_background) { + /* The background should have been filled in advance if a stipple + is enabled. */ + eassert (s->gc->fill_style != ANDROID_FILL_OPAQUE_STIPPLED); + /* Fill the background. First, offset the background rectangle to become relative from text_rectangle.x, text_rectangle.y. */ diff --git a/src/sort.c b/src/sort.c index 527d5550342..02dad327cd4 100644 --- a/src/sort.c +++ b/src/sort.c @@ -38,8 +38,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ static void reverse_slice(Lisp_Object *lo, Lisp_Object *hi) { - eassert (lo && hi); - --hi; while (lo < hi) { Lisp_Object t = *lo; @@ -532,6 +530,9 @@ merge_markmem (void *arg) merge_state *ms = arg; eassume (ms != NULL); + if (ms->allocated_keys != NULL) + mark_objects (ms->allocated_keys, ms->listlen); + if (ms->reloc.size != NULL && *ms->reloc.size > 0) { Lisp_Object *src = (ms->reloc.src->values @@ -1092,7 +1093,7 @@ tim_sort (Lisp_Object predicate, Lisp_Object keyfunc, Lisp_Object *allocated_keys = NULL; merge_state ms; - if (reverse) + if (reverse && 0 < length) reverse_slice (seq, seq + length); /* preserve stability */ if (NILP (keyfunc)) @@ -1107,21 +1108,29 @@ tim_sort (Lisp_Object predicate, Lisp_Object keyfunc, if (length < MERGESTATE_TEMP_SIZE / 2) keys = &ms.temparray[length + 1]; else - keys = allocated_keys = xmalloc (length * word_size); - - for (ptrdiff_t i = 0; i < length; i++) - keys[i] = call1 (keyfunc, seq[i]); + { + /* Fill with valid Lisp values in case a GC occurs before all + keys have been computed. */ + verify (NIL_IS_ZERO); + keys = allocated_keys = xzalloc (length * word_size); + } lo.keys = keys; lo.values = seq; } + merge_init (&ms, length, allocated_keys, &lo, predicate); + + /* Compute keys after merge_markmem has been registered by merge_init + (any call to keyfunc might trigger a GC). */ + if (!NILP (keyfunc)) + for (ptrdiff_t i = 0; i < length; i++) + keys[i] = call1 (keyfunc, seq[i]); + /* FIXME: This is where we would check the keys for interesting properties for more optimised comparison (such as all being fixnums etc). */ - merge_init (&ms, length, allocated_keys, &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); diff --git a/src/sysdep.c b/src/sysdep.c index cf2985b4b89..07237885cb9 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -2037,10 +2037,10 @@ init_signals (void) main_thread_id = pthread_self (); #endif - /* Don't alter signal handlers if dumping. On some machines, - changing signal handlers sets static data that would make signals - fail to work right when the dumped Emacs is run. */ - if (will_dump_p ()) + /* Don't alter signal handlers if dumping with unexec. On some + machines, changing signal handlers sets static data that would make + signals fail to work right when the dumped Emacs is run. */ + if (will_dump_with_unexec_p ()) return; sigfillset (&process_fatal_action.sa_mask); diff --git a/src/term.c b/src/term.c index 3fa244be824..351b0a4310c 100644 --- a/src/term.c +++ b/src/term.c @@ -1416,9 +1416,9 @@ term_get_fkeys_1 (void) /* Define f0 first, so that f10 takes precedence in case the key sequences happens to be the same. */ Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), - make_vector (1, intern ("f0")), Qnil); + make_vector (1, Qf0), Qnil); Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi), - make_vector (1, intern ("f10")), Qnil); + make_vector (1, Qf10), Qnil); } else if (k0) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), @@ -2014,8 +2014,19 @@ turn_on_face (struct frame *f, int face_id) OUTPUT1 (tty, tty->TS_enter_dim_mode); } - if (face->tty_underline_p && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE)) - OUTPUT1_IF (tty, tty->TS_enter_underline_mode); + if (face->underline && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE)) + { + if (face->underline == FACE_UNDERLINE_SINGLE + || !tty->TF_set_underline_style) + OUTPUT1_IF (tty, tty->TS_enter_underline_mode); + else if (tty->TF_set_underline_style) + { + char *p; + p = tparam (tty->TF_set_underline_style, NULL, 0, face->underline, 0, 0, 0); + OUTPUT (tty, p); + xfree (p); + } + } if (face->tty_strike_through_p && MAY_USE_WITH_COLORS_P (tty, NC_STRIKE_THROUGH)) @@ -2041,6 +2052,14 @@ turn_on_face (struct frame *f, int face_id) OUTPUT (tty, p); xfree (p); } + + ts = tty->TF_set_underline_color; + if (ts && face->underline_color) + { + p = tparam (ts, NULL, 0, face->underline_color, 0, 0, 0); + OUTPUT (tty, p); + xfree (p); + } } } @@ -2061,7 +2080,7 @@ turn_off_face (struct frame *f, int face_id) if (face->tty_bold_p || face->tty_italic_p || face->tty_reverse_p - || face->tty_underline_p + || face->underline || face->tty_strike_through_p) { OUTPUT1_IF (tty, tty->TS_exit_attribute_mode); @@ -2073,7 +2092,7 @@ turn_off_face (struct frame *f, int face_id) { /* If we don't have "me" we can only have those appearances that have exit sequences defined. */ - if (face->tty_underline_p) + if (face->underline) OUTPUT_IF (tty, tty->TS_exit_underline_mode); } @@ -2105,6 +2124,9 @@ tty_capable_p (struct tty_display_info *tty, unsigned int caps) TTY_CAP_UNDERLINE, tty->TS_enter_underline_mode, NC_UNDERLINE); TTY_CAPABLE_P_TRY (tty, + TTY_CAP_UNDERLINE_STYLED, tty->TF_set_underline_style, + NC_UNDERLINE); + TTY_CAPABLE_P_TRY (tty, TTY_CAP_BOLD, tty->TS_enter_bold_mode, NC_BOLD); TTY_CAPABLE_P_TRY (tty, TTY_CAP_DIM, tty->TS_enter_dim_mode, NC_DIM); @@ -2253,7 +2275,7 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f) tty->previous_color_mode = mode; tty_setup_colors (tty , mode); /* This recomputes all the faces given the new color definitions. */ - safe_calln (intern ("tty-set-up-initial-frame-faces")); + safe_calln (Qtty_set_up_initial_frame_faces); } } @@ -2290,7 +2312,7 @@ TERMINAL is not on a tty device. */) { struct terminal *t = decode_tty_terminal (terminal); - return (t && !strcmp (t->display_info.tty->name, DEV_TTY) ? Qt : Qnil); + return (t && !strcmp (t->display_info.tty->name, dev_tty) ? Qt : Qnil); } DEFUN ("tty-no-underline", Ftty_no_underline, Stty_no_underline, 0, 1, 0, @@ -2365,7 +2387,7 @@ A suspended tty may be resumed by calling `resume-tty' on it. */) the tty state. */ Lisp_Object term; XSETTERMINAL (term, t); - CALLN (Frun_hook_with_args, intern ("suspend-tty-functions"), term); + CALLN (Frun_hook_with_args, Qsuspend_tty_functions, term); reset_sys_modes (t->display_info.tty); delete_keyboard_wait_descriptor (fileno (f)); @@ -2445,7 +2467,7 @@ frame's terminal). */) open_errno); } - if (!O_IGNORE_CTTY && strcmp (t->display_info.tty->name, DEV_TTY) != 0) + if (!O_IGNORE_CTTY && strcmp (t->display_info.tty->name, dev_tty) != 0) dissociate_if_controlling_tty (fd); #endif /* MSDOS */ @@ -2472,7 +2494,7 @@ frame's terminal). */) /* Run `resume-tty-functions'. */ Lisp_Object term; XSETTERMINAL (term, t); - CALLN (Frun_hook_with_args, intern ("resume-tty-functions"), term); + CALLN (Frun_hook_with_args, Qresume_tty_functions, term); } set_tty_hooks (t); @@ -3255,10 +3277,10 @@ tty_menu_activate (tty_menu *menu, int *pane, int *selidx, SAFE_NALLOCA (state, 1, menu->panecount); memset (state, 0, sizeof (*state)); faces[0] - = lookup_derived_face (NULL, sf, intern ("tty-menu-disabled-face"), + = lookup_derived_face (NULL, sf, Qtty_menu_disabled_face, DEFAULT_FACE_ID, 1); faces[1] - = lookup_derived_face (NULL, sf, intern ("tty-menu-enabled-face"), + = lookup_derived_face (NULL, sf, Qtty_menu_enabled_face, DEFAULT_FACE_ID, 1); selectface = intern ("tty-menu-selected-face"); faces[2] = lookup_derived_face (NULL, sf, selectface, @@ -4053,7 +4075,7 @@ dissociate_if_controlling_tty (int fd) /* Create a termcap display on the tty device with the given name and type. - If NAME is NULL, then use the controlling tty, i.e., DEV_TTY. + If NAME is NULL, then use the controlling tty, i.e., dev_tty. Otherwise NAME should be a path to the tty device file, e.g. "/dev/pts/7". @@ -4092,9 +4114,9 @@ init_tty (const char *name, const char *terminal_type, bool must_succeed) "Unknown terminal type"); if (name == NULL) - name = DEV_TTY; + name = dev_tty; #ifndef DOS_NT - if (!strcmp (name, DEV_TTY)) + if (!strcmp (name, dev_tty)) ctty = 1; #endif @@ -4360,6 +4382,26 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ tty->TF_underscore = tgetflag ("ul"); tty->TF_teleray = tgetflag ("xt"); + /* Styled underlines. Support for this is provided either by the + escape sequence in Smulx or the Su flag. The latter results in a + common default escape sequence and is not recommended. */ +#ifdef TERMINFO + tty->TF_set_underline_style = tigetstr ("Smulx"); + if (tty->TF_set_underline_style == (char *) (intptr_t) -1) + tty->TF_set_underline_style = NULL; +#else + tty->TF_set_underline_style = tgetstr ("Smulx", address); +#endif + if (!tty->TF_set_underline_style && tgetflag ("Su")) + /* Default to the kitty escape sequence. See + https://sw.kovidgoyal.net/kitty/underlines/. */ + tty->TF_set_underline_style = "\x1b[4:%p1%dm"; + + if (tty->TF_set_underline_style) + /* Standard escape sequence to set the underline color. + Requires a single parameter, the color index. */ + tty->TF_set_underline_color = "\x1b[58:2::%p1%{65536}%/%d:%p1%{256}%/%{255}%&%d:%p1%{255}%&%dm"; + #else /* DOS_NT */ #ifdef WINDOWSNT { @@ -4756,4 +4798,12 @@ trigger redisplay. */); DEFSYM (Qtty_menu_mouse_movement, "tty-menu-mouse-movement"); DEFSYM (Qtty_menu_navigation_map, "tty-menu-navigation-map"); #endif + DEFSYM (Qf0, "f0"); + DEFSYM (Qf10, "f10"); + DEFSYM (Qtty_set_up_initial_frame_faces, + "tty-set-up-initial-frame-faces"); + DEFSYM (Qsuspend_tty_functions, "suspend-tty-functions"); + DEFSYM (Qresume_tty_functions, "resume-tty-functions"); + DEFSYM (Qtty_menu_disabled_face, "tty-menu-disabled-face"); + DEFSYM (Qtty_menu_enabled_face, "tty-menu-enabled-face"); } diff --git a/src/termchar.h b/src/termchar.h index 2d845107e11..a1df5a19518 100644 --- a/src/termchar.h +++ b/src/termchar.h @@ -171,6 +171,13 @@ struct tty_display_info non-blank position. Must clear before writing _. */ int TF_teleray; /* termcap xt flag: many weird consequences. For t1061. */ + const char *TF_set_underline_style; /* termcap Smulx entry: Switches the underline + style based on the parameter. Param should + be one of: 0 (none), 1 (straight), 2 (double-line), + 3 (wave), 4 (dots), or 5 (dashes). */ + const char *TF_set_underline_color; /* Enabled when TF_set_underline_style is set: + Sets the color of the underline. Accepts a + single parameter, the color index. */ int RPov; /* # chars to start a TS_repeat */ diff --git a/src/terminal.c b/src/terminal.c index 23a5582d4d9..e8316ba32e8 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -287,14 +287,12 @@ create_terminal (enum output_method type, struct redisplay_interface *rif) /* If default coding systems for the terminal and the keyboard are already defined, use them in preference to the defaults. This is needed when Emacs runs in daemon mode. */ - keyboard_coding = - find_symbol_value (intern ("default-keyboard-coding-system")); + keyboard_coding = find_symbol_value (Qdefault_keyboard_coding_system); if (NILP (keyboard_coding) || BASE_EQ (keyboard_coding, Qunbound) || NILP (Fcoding_system_p (keyboard_coding))) keyboard_coding = Qno_conversion; - terminal_coding = - find_symbol_value (intern ("default-terminal-coding-system")); + terminal_coding = find_symbol_value (Qdefault_terminal_coding_system); if (NILP (terminal_coding) || BASE_EQ (terminal_coding, Qunbound) || NILP (Fcoding_system_p (terminal_coding))) @@ -654,7 +652,6 @@ delete_initial_terminal (struct terminal *terminal) void syms_of_terminal (void) { - DEFVAR_LISP ("ring-bell-function", Vring_bell_function, doc: /* Non-nil means call this function to ring the bell. The function should accept no arguments. */); @@ -681,4 +678,6 @@ or some time later. */); defsubr (&Sset_terminal_parameter); Fprovide (intern_c_string ("multi-tty"), Qnil); + DEFSYM (Qdefault_keyboard_coding_system, "default-keyboard-coding-system"); + DEFSYM (Qdefault_terminal_coding_system, "default-terminal-coding-system"); } diff --git a/src/textconv.c b/src/textconv.c index 9625c884e16..06d9af335c5 100644 --- a/src/textconv.c +++ b/src/textconv.c @@ -141,6 +141,10 @@ select_window (Lisp_Object window, Lisp_Object norecord) w = XWINDOW (window); + /* Work around GCC bug 114893 + <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=114893>. */ + eassume (w); + if (MINI_WINDOW_P (w) && WINDOW_LIVE_P (window) && !EQ (window, Factive_minibuffer_window ())) @@ -195,6 +199,15 @@ textconv_query (struct frame *f, struct textconv_callback_struct *query, : f->selected_window), Qt); w = XWINDOW (selected_window); + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + /* Now find the appropriate text bounds for QUERY. First, move point QUERY->position steps forward or backwards. */ @@ -488,6 +501,17 @@ record_buffer_change (ptrdiff_t beg, ptrdiff_t end, Vtext_conversion_edits); } +/* Reset text conversion state of frame F, and resume text conversion. + Delete any overlays or markers inside. */ + +void +reset_frame_conversion (struct frame *f) +{ + reset_frame_state (f); + if (text_interface && FRAME_WINDOW_P (f) && FRAME_VISIBLE_P (f)) + text_interface->reset (f); +} + /* Reset text conversion state of frame F. Delete any overlays or markers inside. */ @@ -530,6 +554,15 @@ reset_frame_state (struct frame *f) /* Clear batch edit state. */ f->conversion.batch_edit_count = 0; f->conversion.batch_edit_flags = 0; + + /* Clear active field. */ + if (!NILP (f->conversion.field)) + { + Fset_marker (XCAR (f->conversion.field), Qnil, Qnil); + Fset_marker (XCAR (XCDR (f->conversion.field)), Qnil, + Qnil); + } + f->conversion.field = Qnil; } /* Return whether or not there are pending edits from an input method @@ -1012,6 +1045,15 @@ really_delete_surrounding_text (struct frame *f, ptrdiff_t left, redisplay. */ select_window (f->old_selected_window, Qt); + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + /* Figure out where to start deleting from. */ a = get_mark (); @@ -1078,6 +1120,115 @@ really_delete_surrounding_text (struct frame *f, ptrdiff_t left, unbind_to (count, Qnil); } +/* Save the confines of the field surrounding point in w into F's text + conversion state. If NOTIFY_COMPOSE, notify the input method of + changes to the composition region if they arise in this process. */ + +static void +locate_and_save_position_in_field (struct frame *f, struct window *w, + bool notify_compose) +{ + Lisp_Object pos, window, c1, c2; + specpdl_ref count; + ptrdiff_t beg, end, cstart, cend, newstart, newend; + + /* Set the current buffer to W's. */ + count = SPECPDL_INDEX (); + record_unwind_protect (restore_selected_window, selected_window); + XSETWINDOW (window, w); + select_window (window, Qt); + + /* Search for a field around the current editing position; this should + also serve to confine text conversion to the visible region. */ + XSETFASTINT (pos, min (max (w->ephemeral_last_point, BEGV), ZV)); + find_field (pos, Qnil, Qnil, &beg, Qnil, &end); + + /* If beg is 1 and end is ZV, disable the active field entirely. */ + if (beg == 1 && end == ZV) + { + f->conversion.field = Qnil; + goto exit; + } + + /* Don't cons if a pair already exists. */ + if (!NILP (f->conversion.field)) + { + c1 = f->conversion.field; + c2 = XCDR (c1); + Fset_marker (XCAR (c1), make_fixed_natnum (beg), Qnil); + Fset_marker (XCAR (c2), make_fixed_natnum (end), Qnil); + XSETCDR (c2, window); + } + else + { + c1 = build_marker (current_buffer, beg, CHAR_TO_BYTE (beg)); + c2 = build_marker (current_buffer, end, CHAR_TO_BYTE (end)); + Fset_marker_insertion_type (c2, Qt); + f->conversion.field = Fcons (c1, Fcons (c2, window)); + } + + /* If the composition region is active and oversteps the active field, + restrict it to the same. */ + + if (!NILP (f->conversion.compose_region_start)) + { + cstart = marker_position (f->conversion.compose_region_start); + cend = marker_position (f->conversion.compose_region_end); + + if (cend < beg || cstart > end) + { + /* Remove the composition region in whole. */ + /* Make the composition region markers point elsewhere. */ + + if (!NILP (f->conversion.compose_region_start)) + { + Fset_marker (f->conversion.compose_region_start, Qnil, Qnil); + Fset_marker (f->conversion.compose_region_end, Qnil, Qnil); + f->conversion.compose_region_start = Qnil; + f->conversion.compose_region_end = Qnil; + } + + /* Delete the composition region overlay. */ + + if (!NILP (f->conversion.compose_region_overlay)) + Fdelete_overlay (f->conversion.compose_region_overlay); + + TEXTCONV_DEBUG ("removing composing region outside active field"); + } + else + { + newstart = max (beg, min (cstart, end)); + newend = max (beg, min (cend, end)); + + if (newstart != cstart || newend != cend) + { + TEXTCONV_DEBUG ("confined composing region to %td, %td", + newstart, newend); + Fset_marker (f->conversion.compose_region_end, + make_fixed_natnum (newstart), Qnil); + Fset_marker (f->conversion.compose_region_end, + make_fixed_natnum (newend), Qnil); + } + else + notify_compose = false; + } + } + else + notify_compose = false; + + if (notify_compose + && text_interface->compose_region_changed) + { + if (f->conversion.batch_edit_count > 0) + f->conversion.batch_edit_flags |= PENDING_COMPOSE_CHANGE; + else + text_interface->compose_region_changed (f); + } + + exit: + unbind_to (count, Qnil); +} + /* Update the interface with frame F's new point and mark. If a batch edit is in progress, schedule the update for when it finishes instead. */ @@ -1085,6 +1236,8 @@ really_delete_surrounding_text (struct frame *f, ptrdiff_t left, static void really_request_point_update (struct frame *f) { + struct window *w; + /* If F's old selected window is no longer live, fail. */ if (!WINDOW_LIVE_P (f->old_selected_window)) @@ -1093,9 +1246,11 @@ really_request_point_update (struct frame *f) if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else if (text_interface && text_interface->point_changed) - text_interface->point_changed (f, - XWINDOW (f->old_selected_window), - current_buffer); + { + w = XWINDOW (f->old_selected_window); + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, w, current_buffer); + } } /* Set point in frame F's selected window to POSITION. If MARK is not @@ -1130,9 +1285,11 @@ really_set_point_and_mark (struct frame *f, ptrdiff_t point, if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else if (text_interface && text_interface->point_changed) - text_interface->point_changed (f, - XWINDOW (f->old_selected_window), - current_buffer); + { + w = XWINDOW (f->old_selected_window); + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, w, current_buffer); + } } else /* Set the point. */ @@ -1331,7 +1488,10 @@ complete_edit_check (void *ptr) if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else - text_interface->point_changed (f, context->w, NULL); + { + locate_and_save_position_in_field (f, context->w, false); + text_interface->point_changed (f, context->w, NULL); + } } } } @@ -1400,7 +1560,10 @@ handle_pending_conversion_events_1 (struct frame *f, break; if (f->conversion.batch_edit_flags & PENDING_POINT_CHANGE) - text_interface->point_changed (f, w, buffer); + { + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, w, buffer); + } if (f->conversion.batch_edit_flags & PENDING_COMPOSE_CHANGE) text_interface->compose_region_changed (f); @@ -1529,7 +1692,10 @@ handle_pending_conversion_events (void) if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else - text_interface->point_changed (f, NULL, NULL); + { + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, NULL, NULL); + } } last_point = w->ephemeral_last_point; @@ -1564,6 +1730,39 @@ handle_pending_conversion_events (void) unbind_to (count, Qnil); } +/* Return the confines of the field to which editing operations on frame + F should be constrained in *BEG and *END. Should no field be active, + set *END to MOST_POSITIVE_FIXNUM. */ + +void +get_conversion_field (struct frame *f, ptrdiff_t *beg, ptrdiff_t *end) +{ + Lisp_Object c1, c2; + struct window *w; + + if (!NILP (f->conversion.field)) + { + c1 = f->conversion.field; + c2 = XCDR (c1); + + if (!EQ (XCDR (c2), f->old_selected_window)) + { + /* Update this outdated field location. */ + w = XWINDOW (f->old_selected_window); + locate_and_save_position_in_field (f, w, true); + get_conversion_field (f, beg, end); + return; + } + + *beg = marker_position (XCAR (c1)); + *end = marker_position (XCAR (c2)); + return; + } + + *beg = 1; + *end = MOST_POSITIVE_FIXNUM; +} + /* Start a ``batch edit'' in frame F. During a batch edit, point_changed will not be called until the batch edit ends. @@ -1694,7 +1893,8 @@ set_composing_text (struct frame *f, Lisp_Object object, } /* Make the region between START and END the currently active - ``composing region'' on frame F. + ``composing region'' on frame F. Which of START and END is the + larger value is not significant. The ``composing region'' is a region of text in the buffer that is about to undergo editing by the input method. */ @@ -1704,14 +1904,22 @@ set_composing_region (struct frame *f, ptrdiff_t start, ptrdiff_t end, unsigned long counter) { struct text_conversion_action *action, **last; + ptrdiff_t field_start, field_end, temp; + + if (start > end) + { + temp = end; + end = start; + start = temp; + } - start = min (start, MOST_POSITIVE_FIXNUM); - end = min (end, MOST_POSITIVE_FIXNUM); + get_conversion_field (f, &field_start, &field_end); + start = min (start + field_start - 1, MOST_POSITIVE_FIXNUM); + end = max (start, min (end + field_start - 1, field_end)); action = xmalloc (sizeof *action); action->operation = TEXTCONV_SET_COMPOSING_REGION; - action->data = Fcons (make_fixnum (start), - make_fixnum (end)); + action->data = Fcons (make_fixnum (start), make_fixnum (end)); action->next = NULL; action->counter = counter; for (last = &f->conversion.actions; *last; last = &(*last)->next) @@ -1730,8 +1938,13 @@ textconv_set_point_and_mark (struct frame *f, ptrdiff_t point, ptrdiff_t mark, unsigned long counter) { struct text_conversion_action *action, **last; + ptrdiff_t field_start, field_end; - point = min (point, MOST_POSITIVE_FIXNUM); + get_conversion_field (f, &field_start, &field_end); + point = min (max (point + field_start - 1, field_start), + field_end); + mark = min (max (mark + field_start - 1, field_start), + field_end); action = xmalloc (sizeof *action); action->operation = TEXTCONV_SET_POINT_AND_MARK; @@ -1809,10 +2022,11 @@ textconv_barrier (struct frame *f, unsigned long counter) input_pending = true; } -/* Remove the composing region. Replace the text between START and - END within F's selected window with TEXT; deactivate the mark if it - is active. Subsequently, set point to POSITION relative to TEXT, - much as `commit_text' would. */ +/* Remove the composing region. Replace the text between START and END + (whose order, as in `set_composing_region', is not significant) + within F's selected window with TEXT; deactivate the mark if it is + active. Subsequently, set point to POSITION relative to TEXT, as + `commit_text' would. */ void replace_text (struct frame *f, ptrdiff_t start, ptrdiff_t end, @@ -1820,6 +2034,18 @@ replace_text (struct frame *f, ptrdiff_t start, ptrdiff_t end, unsigned long counter) { struct text_conversion_action *action, **last; + ptrdiff_t field_start, field_end, temp; + + if (start > end) + { + temp = end; + end = start; + start = temp; + } + + get_conversion_field (f, &field_start, &field_end); + start = min (start + field_start - 1, MOST_POSITIVE_FIXNUM); + end = max (start, min (end + field_start - 1, field_end)); action = xmalloc (sizeof *action); action->operation = TEXTCONV_REPLACE_TEXT; @@ -1858,6 +2084,7 @@ get_extracted_text (struct frame *f, ptrdiff_t n, specpdl_ref count; ptrdiff_t start, end, start_byte, end_byte, mark; char *buffer; + ptrdiff_t field_start, field_end; if (!WINDOW_LIVE_P (f->old_selected_window)) return NULL; @@ -1907,6 +2134,15 @@ get_extracted_text (struct frame *f, ptrdiff_t n, goto finish; } + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + start = max (start, BEGV); end = min (end, ZV); @@ -1935,7 +2171,8 @@ get_extracted_text (struct frame *f, ptrdiff_t n, } /* Return the offsets. */ - *start_return = start; + get_conversion_field (f, &field_start, &field_end); + *start_return = max (1, start - field_start + 1); *start_offset = min (mark - start, PT - start); *end_offset = max (mark - start, PT - start); *length = end - start; @@ -1968,6 +2205,7 @@ get_surrounding_text (struct frame *f, ptrdiff_t left, { specpdl_ref count; ptrdiff_t start, end, start_byte, end_byte, mark, temp; + ptrdiff_t field_start, field_end; char *buffer; if (!WINDOW_LIVE_P (f->old_selected_window)) @@ -2012,6 +2250,15 @@ get_surrounding_text (struct frame *f, ptrdiff_t left, || ckd_add (&end, end, right)) goto finish; + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + start = max (start, BEGV); end = min (end, ZV); @@ -2038,7 +2285,8 @@ get_surrounding_text (struct frame *f, ptrdiff_t left, /* Return the offsets. Unlike `get_extracted_text', this need not sort mark and point. */ - *offset = start; + get_conversion_field (f, &field_start, &field_end); + *offset = max (1, start - field_start + 1); *start_return = mark - start; *end_return = PT - start; *length = end - start; @@ -2110,7 +2358,10 @@ report_point_change (struct frame *f, struct window *window, if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else - text_interface->point_changed (f, window, buffer); + { + locate_and_save_position_in_field (f, window, false); + text_interface->point_changed (f, window, buffer); + } } /* Temporarily disable text conversion. Must be paired with a @@ -2348,8 +2599,9 @@ as indenting or automatically filling text, should not take place. Otherwise, it is either a string containing text that was inserted, text deleted before point, or nil if text was deleted after point. -The list contents are ordered in the reverse order of editing, i.e. -the latest edit first, so you must iterate through the list in reverse. */); +The list contents are arranged in the reverse of the order of editing, +i.e. latest edit first, so you must iterate through the list in +reverse. */); Vtext_conversion_edits = Qnil; DEFVAR_LISP ("overriding-text-conversion-style", diff --git a/src/textconv.h b/src/textconv.h index 61f13ebcb43..e87ff5cd1f8 100644 --- a/src/textconv.h +++ b/src/textconv.h @@ -155,6 +155,7 @@ extern char *get_surrounding_text (struct frame *, ptrdiff_t, extern bool conversion_disabled_p (void); extern void check_postponed_buffers (void); +extern void get_conversion_field (struct frame *, ptrdiff_t *, ptrdiff_t *); extern void register_textconv_interface (struct textconv_interface *); #endif /* _TEXTCONV_H_ */ diff --git a/src/textprop.c b/src/textprop.c index 7d9aae0d2c5..84d6b5f1545 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -2186,6 +2186,7 @@ verify_interval_modification (struct buffer *buf, { INTERVAL intervals = buffer_intervals (buf); INTERVAL i; + ptrdiff_t p; Lisp_Object hooks; Lisp_Object prev_mod_hooks; Lisp_Object mod_hooks; @@ -2314,14 +2315,30 @@ verify_interval_modification (struct buffer *buf, } else { + bool buffer_read_only; + /* Loop over intervals on or next to START...END, collecting their hooks. */ + /* Extent of last writable interval. */ i = find_interval (intervals, start); + p = 0; + buffer_read_only = (!NILP (BVAR (current_buffer, read_only)) + && NILP (Vinhibit_read_only)); do { - if (! INTERVAL_WRITABLE_P (i)) - text_read_only (textget (i->plist, Qread_only)); + bool implied, express; + Lisp_Object read_only; + + read_only = textget ((i)->plist, Qread_only); + implied = INTERVAL_GENERALLY_WRITABLE_P (i, read_only); + express = INTERVAL_EXPRESSLY_WRITABLE_P (i, read_only); + if (!implied && !express) + text_read_only (read_only); + /* If this interval is only implicitly read only and the + buffer is read only as a whole, signal an error. */ + else if (!express && buffer_read_only) + xsignal1 (Qbuffer_read_only, Fcurrent_buffer ()); if (!inhibit_modification_hooks) { @@ -2333,16 +2350,18 @@ verify_interval_modification (struct buffer *buf, } } - if (i->position + LENGTH (i) < end - && (!NILP (BVAR (current_buffer, read_only)) - && NILP (Vinhibit_read_only))) - xsignal1 (Qbuffer_read_only, Fcurrent_buffer ()); - + p = i->position + LENGTH (i); i = next_interval (i); } /* Keep going thru the interval containing the char before END. */ while (i && i->position < end); + /* Should the buffer be read only while the last interval with an + `inhibit-read-only' property does not enclose the entire change + under consideration, signal error. */ + if (p < end && buffer_read_only) + xsignal1 (Qbuffer_read_only, Fcurrent_buffer ()); + if (!inhibit_modification_hooks) { hooks = Fnreverse (hooks); diff --git a/src/treesit.c b/src/treesit.c index d86ab501187..52d158b1bf8 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -1017,9 +1017,8 @@ treesit_check_buffer_size (struct buffer *buffer) static Lisp_Object treesit_make_ranges (const TSRange *, uint32_t, struct buffer *); -static void -treesit_call_after_change_functions (TSTree *old_tree, TSTree *new_tree, - Lisp_Object parser) +static Lisp_Object +treesit_get_changed_ranges (TSTree *old_tree, TSTree *new_tree, Lisp_Object parser) { /* If the old_tree is NULL, meaning this is the first parse, the changed range is the whole buffer. */ @@ -1039,7 +1038,13 @@ treesit_call_after_change_functions (TSTree *old_tree, TSTree *new_tree, lisp_ranges = Fcons (Fcons (Fpoint_min (), Fpoint_max ()), Qnil); set_buffer_internal (oldbuf); } + return lisp_ranges; +} +static void +treesit_call_after_change_functions (Lisp_Object lisp_ranges, + Lisp_Object parser) +{ specpdl_ref count = SPECPDL_INDEX (); /* let's trust the after change functions and not clone a new ranges @@ -1091,13 +1096,17 @@ treesit_ensure_parsed (Lisp_Object parser) XTS_PARSER (parser)->tree = new_tree; XTS_PARSER (parser)->need_reparse = false; + Lisp_Object changed_ranges; + changed_ranges = treesit_get_changed_ranges (tree, new_tree, parser); + XTS_PARSER (parser)->last_changed_ranges = changed_ranges; + /* After-change functions should run at the very end, most crucially after need_reparse is set to false, this way if the function calls some tree-sitter function which invokes treesit_ensure_parsed again, it returns early and do not recursively call the after change functions again. (ref:notifier-inside-ensure-parsed) */ - treesit_call_after_change_functions (tree, new_tree, parser); + treesit_call_after_change_functions (changed_ranges, parser); ts_tree_delete (tree); } @@ -1171,6 +1180,7 @@ make_treesit_parser (Lisp_Object buffer, TSParser *parser, lisp_parser->after_change_functions = Qnil; lisp_parser->tag = tag; lisp_parser->last_set_ranges = Qnil; + lisp_parser->last_changed_ranges = Qnil; lisp_parser->buffer = buffer; lisp_parser->parser = parser; lisp_parser->tree = tree; @@ -1818,6 +1828,32 @@ positions. PARSER is the parser issuing the notification. */) return Qnil; } +DEFUN ("treesit-parser-changed-ranges", Ftreesit_parser_changed_ranges, + Streesit_parser_changed_ranges, + 1, 2, 0, + doc: /* Return the buffer regions affected by the last reparse of PARSER. + +Returns a list of cons cells (BEG . END), where each cons cell represents +a region in which changes in buffer contents affected the last reparse. + +This function should almost always be called immediately after +reparsing. If it's called when there are new buffer edits that hasn't +been reparsed, Emacs signals the `treesit-unparsed-edits' error, unless +optional argument QUIET is non-nil. + +Calling this function multiple times consecutively doesn't change its +return value; it always returns the ranges affected by the last +reparse. */) + (Lisp_Object parser, Lisp_Object quiet) +{ + treesit_check_parser (parser); + + if (XTS_PARSER (parser)->need_reparse && NILP (quiet)) + xsignal1 (Qtreesit_unparsed_edits, parser); + + return XTS_PARSER (parser)->last_changed_ranges; +} + /*** Node API */ @@ -4010,6 +4046,7 @@ syms_of_treesit (void) DEFSYM (Qtreesit_query_error, "treesit-query-error"); DEFSYM (Qtreesit_parse_error, "treesit-parse-error"); DEFSYM (Qtreesit_range_invalid, "treesit-range-invalid"); + DEFSYM (Qtreesit_unparsed_edits, "treesit-unparsed_edits"); DEFSYM (Qtreesit_buffer_too_large, "treesit-buffer-too-large"); DEFSYM (Qtreesit_load_language_error, @@ -4038,6 +4075,8 @@ syms_of_treesit (void) define_error (Qtreesit_range_invalid, "RANGES are invalid: they have to be ordered and should not overlap", Qtreesit_error); + define_error (Qtreesit_unparsed_edits, "There are unparsed edits in the buffer", + Qtreesit_error); define_error (Qtreesit_buffer_too_large, "Buffer too large (> 4GiB)", Qtreesit_error); define_error (Qtreesit_load_language_error, @@ -4178,6 +4217,8 @@ the symbol of that THING. For example, (or sexp sentence). */); defsubr (&Streesit_parser_add_notifier); defsubr (&Streesit_parser_remove_notifier); + defsubr (&Streesit_parser_changed_ranges); + defsubr (&Streesit_node_type); defsubr (&Streesit_node_start); defsubr (&Streesit_node_end); diff --git a/src/treesit.h b/src/treesit.h index bb81bf0e2b3..aa71933fe8d 100644 --- a/src/treesit.h +++ b/src/treesit.h @@ -49,6 +49,9 @@ struct Lisp_TS_Parser ranges the users wants to set, and avoid reparse if the new ranges is the same as the last set one. */ Lisp_Object last_set_ranges; + /* The range of buffer content that was affected by the last + re-parse. */ + Lisp_Object last_changed_ranges; /* The buffer associated with this parser. */ Lisp_Object buffer; /* The pointer to the tree-sitter parser. Never NULL. */ diff --git a/src/w32fns.c b/src/w32fns.c index ace8d1016a5..8b61b54bdc5 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -6539,7 +6539,7 @@ DEFUN ("x-display-backing-store", Fx_display_backing_store, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { - return intern ("not-useful"); + return Qnot_useful; } DEFUN ("x-display-visual-class", Fx_display_visual_class, @@ -6551,13 +6551,13 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class, Lisp_Object result = Qnil; if (dpyinfo->has_palette) - result = intern ("pseudo-color"); + result = Qpseudo_color; else if (dpyinfo->n_planes * dpyinfo->n_cbits == 1) - result = intern ("static-gray"); + result = Qstatic_gray; else if (dpyinfo->n_planes * dpyinfo->n_cbits == 4) - result = intern ("static-color"); + result = Qstatic_color; else if (dpyinfo->n_planes * dpyinfo->n_cbits > 8) - result = intern ("true-color"); + result = Qtrue_color; return result; } @@ -6773,17 +6773,17 @@ SOUND is nil to use the normal beep. */) if (NILP (sound)) sound_type = 0xFFFFFFFF; - else if (EQ (sound, intern ("asterisk"))) + else if (EQ (sound, Qasterisk)) sound_type = MB_ICONASTERISK; - else if (EQ (sound, intern ("exclamation"))) + else if (EQ (sound, Qexclamation)) sound_type = MB_ICONEXCLAMATION; - else if (EQ (sound, intern ("hand"))) + else if (EQ (sound, Qhand)) sound_type = MB_ICONHAND; - else if (EQ (sound, intern ("question"))) + else if (EQ (sound, Qquestion)) sound_type = MB_ICONQUESTION; - else if (EQ (sound, intern ("ok"))) + else if (EQ (sound, Qok)) sound_type = MB_OK; - else if (EQ (sound, intern ("silent"))) + else if (EQ (sound, Qsilent)) sound_type = MB_EMACS_SILENT; else sound_type = 0xFFFFFFFF; @@ -6854,7 +6854,7 @@ DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, if (NILP (Ffile_readable_p (color_file))) color_file = Fexpand_file_name (build_string ("rgb.txt"), - Fsymbol_value (intern ("data-directory"))); + Fsymbol_value (Qdata_directory)); Vw32_color_map = Fx_load_color_file (color_file); } @@ -7749,8 +7749,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, start_timer: /* Let the tip disappear after timeout seconds. */ - tip_timer = call3 (intern ("run-at-time"), timeout, Qnil, - intern ("x-hide-tip")); + tip_timer = call3 (Qrun_at_time, timeout, Qnil, + Qx_hide_tip); return unbind_to (count, Qnil); } @@ -8188,15 +8188,14 @@ DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0, filename = Qnil; /* An error occurred, fallback on reading from the mini-buffer. */ else - filename = Fcompleting_read ( - orig_prompt, - intern ("read-file-name-internal"), - orig_dir, - mustmatch, - orig_dir, - Qfile_name_history, - default_filename, - Qnil); + filename = Fcompleting_read (orig_prompt, + Qread_file_name_internal, + orig_dir, + mustmatch, + orig_dir, + Qfile_name_history, + default_filename, + Qnil); } /* Make "Cancel" equivalent to C-g. */ @@ -8223,7 +8222,7 @@ DEFUN ("system-move-file-to-trash", Fsystem_move_file_to_trash, if (!NILP (Ffile_directory_p (filename)) && NILP (Ffile_symlink_p (filename))) { - operation = intern ("delete-directory"); + operation = Qdelete_directory; filename = Fdirectory_file_name (filename); } @@ -8927,11 +8926,11 @@ to change the state. */) int vk_code; LPARAM lparam; - if (EQ (key, intern ("capslock"))) + if (EQ (key, Qcapslock)) vk_code = VK_CAPITAL; - else if (EQ (key, intern ("kp-numlock"))) + else if (EQ (key, Qkp_numlock)) vk_code = VK_NUMLOCK; - else if (EQ (key, intern ("scroll"))) + else if (EQ (key, Qscroll)) vk_code = VK_SCROLL; else return Qnil; @@ -10714,6 +10713,7 @@ syms_of_w32fns (void) DEFSYM (Qtip_frame, "tip-frame"); DEFSYM (Qassq_delete_all, "assq-delete-all"); DEFSYM (Qunicode_sip, "unicode-sip"); + DEFSYM (Qread_file_name_internal, "read-file-name-internal"); #if defined WINDOWSNT && !defined HAVE_DBUS DEFSYM (QCicon, ":icon"); DEFSYM (QCtip, ":tip"); @@ -11108,6 +11108,23 @@ keys when IME input is received. */); defsubr (&Ssystem_move_file_to_trash); defsubr (&Sw32_set_wallpaper); #endif + + DEFSYM (Qnot_useful, "not-useful"); + DEFSYM (Qpseudo_color, "pseudo-color"); + DEFSYM (Qstatic_gray, "static-gray"); + DEFSYM (Qstatic_color, "static-color"); + DEFSYM (Qtrue_color, "true-color"); + DEFSYM (Qasterisk, "asterisk"); + DEFSYM (Qexclamation, "exclamation"); + DEFSYM (Qquestion, "question"); + DEFSYM (Qok, "ok"); + DEFSYM (Qsilent, "silent"); + DEFSYM (Qdata_directory, "data-directory"); + DEFSYM (Qrun_at_time, "run-at-time"); + DEFSYM (Qx_hide_tip, "x-hide-tip"); + DEFSYM (Qcapslock, "capslock"); + DEFSYM (Qkp_numlock, "kp-numlock"); + DEFSYM (Qscroll, "scroll"); } diff --git a/src/w32font.c b/src/w32font.c index 56061c0d9ce..1c2da1b26fc 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -1196,15 +1196,15 @@ w32_enumfont_pattern_entity (Lisp_Object frame, if (EQ (backend, Quniscribe) && (full_type & NTMFLAGS_OPENTYPE)) tem = Qopentype; else if (font_type & TRUETYPE_FONTTYPE) - tem = intern ("truetype"); + tem = Qtruetype; else if (full_type & NTM_PS_OPENTYPE) tem = Qpostscript; else if (full_type & NTM_TYPE1) - tem = intern ("type1"); + tem = Qtype1; else if (font_type & RASTER_FONTTYPE) - tem = intern ("w32bitmap"); + tem = Qw32bitmap; else - tem = intern ("w32vector"); + tem = Qw32vector; font_put_extra (entity, QCformat, tem); @@ -2773,6 +2773,12 @@ syms_of_w32font (void) DEFSYM (Qsubpixel, "subpixel"); DEFSYM (Qnatural, "natural"); + /* Font formats. */ + DEFSYM (Qtruetype, "truetype"); + DEFSYM (Qtype1, "type1"); + DEFSYM (Qw32bitmap, "w32bitmap"); + DEFSYM (Qw32vector, "w32vector"); + /* Languages */ DEFSYM (Qzh, "zh"); diff --git a/src/w32term.c b/src/w32term.c index 7afd1303b4d..a9aff304771 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -2535,6 +2535,89 @@ w32_draw_stretch_glyph_string (struct glyph_string *s) s->background_filled_p = true; } +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto F + at a vertical offset of OFFSET from the position of the glyph string + S, with each segment SEGMENT pixels in length, and in the color + FOREGROUND. */ + +static void +w32_draw_dash (struct frame *f, struct glyph_string *s, + COLORREF foreground, int width, char segment, + int offset, int thickness) +{ + int y_base, which, length, x, doffset; + HDC hdc = s->hdc; + + /* A pen with PS_DASH (or PS_DOT) is unsuitable for two reasons: first + that PS_DASH does not accept width values greater than 1, with + itself considered equivalent to PS_SOLID if such a value be + specified, and second that it does not provide for an offset to be + applied to the pattern, absent which Emacs cannot align dashes that + are displayed at locations not multiples of each other. I can't be + bothered to research this matter further, so, for want of a better + option, draw the specified pattern manually. */ + + y_base = s->ybase + offset; + + /* Remove redundant portions of OFFSET. */ + doffset = s->x % (segment * 2); + + /* Set which to the phase of the first dash that ought to be drawn and + length to its length. */ + which = doffset < segment; + length = segment - (s->x % segment); + + /* Begin drawing this dash. */ + for (x = s->x; x < s->x + width; x += length, length = segment) + { + if (which) + w32_fill_area (f, hdc, foreground, x, y_base, length, + thickness); + + which = !which; + } +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, in the color FOREGROUND that is + THICKNESS in height. */ + +static void +w32_fill_underline (struct frame *f, struct glyph_string *s, + COLORREF foreground, + enum face_underline_type style, int position, + int thickness) +{ + int segment; + + segment = thickness * 3; + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + w32_fill_area (s->f, s->hdc, foreground, s->x, + s->ybase + position, s->width, thickness); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + w32_draw_dash (f, s, foreground, s->width, segment, position, + thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} /* Draw glyph string S. */ @@ -2641,7 +2724,7 @@ w32_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { COLORREF color; @@ -2652,13 +2735,14 @@ w32_draw_glyph_string (struct glyph_string *s) w32_draw_underwave (s, color); } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; + COLORREF foreground; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -2734,18 +2818,26 @@ w32_draw_glyph_string (struct glyph_string *s) if (s->y + s->height < s->ybase + position + thickness) thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; - s->underline_position = position; - y = s->ybase + position; + s->underline_position = position; + if (s->face->underline_defaulted_p) - { - w32_fill_area (s->f, s->hdc, s->gc->foreground, s->x, - y, s->width, 1); - } - else - { - w32_fill_area (s->f, s->hdc, s->face->underline_color, s->x, - y, s->width, 1); - } + foreground = s->gc->foreground; + else + foreground = s->face->underline_color; + + w32_fill_underline (s->f, s, foreground, s->face->underline, + position, thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + w32_fill_underline (s->f, s, foreground, s->face->underline, + position, thickness); + } } } /* Draw overline. */ @@ -6403,17 +6495,17 @@ w32_bitmap_icon (struct frame *f, Lisp_Object icon) { LPCTSTR name; - if (EQ (icon, intern ("application"))) + if (EQ (icon, Qapplication)) name = (LPCTSTR) IDI_APPLICATION; - else if (EQ (icon, intern ("hand"))) + else if (EQ (icon, Qhand)) name = (LPCTSTR) IDI_HAND; - else if (EQ (icon, intern ("question"))) + else if (EQ (icon, Qquestion)) name = (LPCTSTR) IDI_QUESTION; - else if (EQ (icon, intern ("exclamation"))) + else if (EQ (icon, Qexclamation)) name = (LPCTSTR) IDI_EXCLAMATION; - else if (EQ (icon, intern ("asterisk"))) + else if (EQ (icon, Qasterisk)) name = (LPCTSTR) IDI_ASTERISK; - else if (EQ (icon, intern ("winlogo"))) + else if (EQ (icon, Qwinlogo)) name = (LPCTSTR) IDI_WINLOGO; else return 1; @@ -7820,6 +7912,10 @@ syms_of_w32term (void) DEFSYM (Qrenamed_from, "renamed-from"); DEFSYM (Qrenamed_to, "renamed-to"); + /* Bitmap icon constants. */ + DEFSYM (Qapplication, "application"); + DEFSYM (Qwinlogo, "winlogo"); + DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout, doc: /* SKIP: real doc in xterm.c. */); Vx_wait_for_event_timeout = make_float (0.1); diff --git a/src/window.c b/src/window.c index fe26311fbb2..cf12841bd51 100644 --- a/src/window.c +++ b/src/window.c @@ -3514,6 +3514,10 @@ window-start value is reasonable when this function is called. */) get called. */ w->optional_new_start = true; + /* Reset the vscroll, as redisplay will not. */ + w->vscroll = 0; + w->preserve_vscroll_p = false; + set_buffer_internal (obuf); } } @@ -5376,7 +5380,6 @@ grow_mini_window (struct window *w, int delta) struct window *r = XWINDOW (root); Lisp_Object grow; - FRAME_WINDOWS_FROZEN (f) = true; grow = call3 (Qwindow__resize_root_window_vertically, root, make_fixnum (- delta), Qt); @@ -5390,6 +5393,8 @@ grow_mini_window (struct window *w, int delta) && window_resize_check (r, false)) resize_mini_window_apply (w, -XFIXNUM (grow)); } + FRAME_WINDOWS_FROZEN (f) + = window_body_height (w, WINDOW_BODY_IN_PIXELS) > FRAME_LINE_HEIGHT (f); } /** @@ -5413,7 +5418,6 @@ shrink_mini_window (struct window *w) struct window *r = XWINDOW (root); Lisp_Object grow; - FRAME_WINDOWS_FROZEN (f) = false; grow = call3 (Qwindow__resize_root_window_vertically, root, make_fixnum (delta), Qt); @@ -5425,6 +5429,8 @@ shrink_mini_window (struct window *w) bar. */ grow_mini_window (w, -delta); + FRAME_WINDOWS_FROZEN (f) + = window_body_height (w, WINDOW_BODY_IN_PIXELS) > FRAME_LINE_HEIGHT (f); } DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, @@ -5749,6 +5755,11 @@ window_scroll_for_long_lines (struct window *w, int n, bool noerror) else if (n < 0) pos = *vmotion (PT, PT_BYTE, - (ht / 2), w); SET_PT_BOTH (pos.bufpos, pos.bytepos); + + /* Since `vmotion' computes coordinates after vscroll is applied, + it is taken into account in POS, and vscroll must be reset by + `force_start' in `redisplay_internal'. */ + w->preserve_vscroll_p = false; } else { @@ -6892,8 +6903,14 @@ and redisplay normally--don't erase and redraw the frame. */) /* Set the new window start. */ set_marker_both (w->start, w->contents, charpos, bytepos); - w->window_end_valid = false; + /* The window start was calculated with an iterator already adjusted + by the existing vscroll, so w->start must not be combined with + retaining the existing vscroll, which redisplay will not reset if + w->preserve_vscroll_p is enabled. (bug#70386) */ + w->vscroll = 0; + w->preserve_vscroll_p = false; + w->window_end_valid = false; w->optional_new_start = true; w->start_at_line_beg = (bytepos == BEGV_BYTE @@ -6981,6 +6998,11 @@ from the top of the window. */) set_marker_both (w->start, w->contents, PT, PT_BYTE); w->start_at_line_beg = !NILP (Fbolp ()); w->force_start = true; + + /* Since `Fvertical_motion' computes coordinates after vscroll is + applied, it is taken into account in POS, and vscroll must be + reset by `force_start' in `redisplay_internal'. */ + w->preserve_vscroll_p = false; } else Fgoto_char (w->start); diff --git a/src/xdisp.c b/src/xdisp.c index 140d71129f3..a7cae804006 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -12053,8 +12053,8 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte) bool newbuffer = NILP (Fget_buffer (Vmessages_buffer_name)); Fset_buffer (Fget_buffer_create (Vmessages_buffer_name, Qnil)); if (newbuffer - && !NILP (Ffboundp (intern ("messages-buffer-mode")))) - call0 (intern ("messages-buffer-mode")); + && !NILP (Ffboundp (Qmessages_buffer_mode))) + call0 (Qmessages_buffer_mode); bset_undo_list (current_buffer, Qt); bset_cache_long_scans (current_buffer, Qnil); @@ -16863,6 +16863,13 @@ redisplay_internal (void) redisplay_trace ("redisplay_internal %d\n", redisplaying_p); + /* I don't think this happens but let's be paranoid. In particular, + this was observed happening when Emacs shuts down due to losing X + connection, in which case accessing SELECTED_FRAME and the frame + structure is likely to barf. */ + if (redisplaying_p) + return; + /* No redisplay if running in batch mode or frame is not yet fully initialized, or redisplay is explicitly turned off by setting Vinhibit_redisplay. */ @@ -16890,10 +16897,6 @@ redisplay_internal (void) return; #endif - /* I don't think this happens but let's be paranoid. */ - if (redisplaying_p) - return; - /* Record a function that clears redisplaying_p when we leave this function. */ specpdl_ref count = SPECPDL_INDEX (); @@ -17847,6 +17850,7 @@ mark_window_display_accurate_1 (struct window *w, bool accurate_p) if ((prev_point != w->last_point || prev_mark != w->last_mark) && FRAME_WINDOW_P (WINDOW_XFRAME (w)) + && !FRAME_TOOLTIP_P (WINDOW_XFRAME (w)) && w == XWINDOW (WINDOW_XFRAME (w)->selected_window)) report_point_change (WINDOW_XFRAME (w), w, b); #endif /* HAVE_TEXT_CONVERSION */ @@ -18179,7 +18183,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, --glyph; /* By default, in reversed rows we put the cursor on the rightmost (first in the reading order) glyph. */ - for (x = 0, g = end + 1; g < glyph; g++) + for (x = row->x, g = end + 1; g < glyph; g++) x += g->pixel_width; while (end < glyph && NILP ((end + 1)->object) @@ -20202,7 +20206,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) /* The vscroll should be preserved in this case, since `pixel-scroll-precision-mode' must continue working normally when a mini-window is resized. (bug#55312) */ - if (!w->preserve_vscroll_p || !window_frozen_p (w)) + if (!w->preserve_vscroll_p && !window_frozen_p (w)) w->vscroll = 0; w->preserve_vscroll_p = false; @@ -24412,6 +24416,7 @@ push_prefix_prop (struct it *it, Lisp_Object prop) { it->method = GET_FROM_STRETCH; it->object = prop; + it->string_from_prefix_prop_p = true; } #ifdef HAVE_WINDOW_SYSTEM else if (IMAGEP (prop)) @@ -24419,6 +24424,7 @@ push_prefix_prop (struct it *it, Lisp_Object prop) it->what = IT_IMAGE; it->image_id = lookup_image (it->f, prop, it->face_id); it->method = GET_FROM_IMAGE; + it->string_from_prefix_prop_p = true; } #endif /* HAVE_WINDOW_SYSTEM */ else @@ -28857,7 +28863,7 @@ decode_mode_spec (struct window *w, register int c, int field_width, Lisp_Object val = Qnil; if (STRINGP (curdir)) - val = dsafe_call1 (intern ("file-remote-p"), curdir); + val = dsafe_call1 (Qfile_remote_p, curdir); val = unbind_to (count, val); @@ -35373,15 +35379,15 @@ define_frame_cursor1 (struct frame *f, Emacs_Cursor cursor, Lisp_Object pointer) cursor = FRAME_OUTPUT_DATA (f)->hand_cursor; else if (EQ (pointer, Qtext)) cursor = FRAME_OUTPUT_DATA (f)->text_cursor; - else if (EQ (pointer, intern ("hdrag"))) + else if (EQ (pointer, Qhdrag)) cursor = FRAME_OUTPUT_DATA (f)->horizontal_drag_cursor; - else if (EQ (pointer, intern ("nhdrag"))) + else if (EQ (pointer, Qnhdrag)) cursor = FRAME_OUTPUT_DATA (f)->vertical_drag_cursor; # ifdef HAVE_X_WINDOWS - else if (EQ (pointer, intern ("vdrag"))) + else if (EQ (pointer, Qvdrag)) cursor = FRAME_DISPLAY_INFO (f)->vertical_scroll_bar_cursor; # endif - else if (EQ (pointer, intern ("hourglass"))) + else if (EQ (pointer, Qhourglass)) cursor = FRAME_OUTPUT_DATA (f)->hourglass_cursor; else if (EQ (pointer, Qmodeline)) cursor = FRAME_OUTPUT_DATA (f)->modeline_cursor; @@ -35730,6 +35736,83 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, } +/* Take proper action when mouse has moved to the window WINDOW, with + window-local x-position X and y-position Y. This is only used for + displaying user-defined fringe indicator help-echo messages. */ + +static void +note_fringe_highlight (struct frame *f, Lisp_Object window, int x, int y, + enum window_part part) +{ + if (!NILP (help_echo_string) || !f->glyphs_initialized_p) + return; + + /* When a menu is active, don't highlight because this looks odd. */ +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) || defined (MSDOS) \ + || defined (HAVE_ANDROID) + if (popup_activated ()) + return; +#endif /* HAVE_X_WINDOWS || HAVE_NS || MSDOS || HAVE_ANDROID */ + +#if defined HAVE_HAIKU + if (popup_activated_p) + return; +#endif /* HAVE_HAIKU */ + + /* Find a message to display through the help-echo mechanism whenever + the mouse hovers over a fringe indicator. Both text properties and + overlays have to be checked. */ + + /* Check the text property symbol to use. */ + Lisp_Object sym; + if (part == ON_LEFT_FRINGE) + sym = Qleft_fringe_help; + else + sym = Qright_fringe_help; + + /* Translate windows coordinates into a vertical window position. */ + int hpos, vpos, area; + struct window *w = XWINDOW (window); + if (x_y_to_hpos_vpos (w, x, y, &hpos, &vpos, 0, 0, &area) == NULL) + return; /* not all glyph rows between 0 and Y are enabled */ + + /* Don't access the TEXT_AREA of a row that does not display text, + when the window is outdated, or when vpos overflows the current + matrix. (bug#70385) */ + if (!w->window_end_valid + || window_outdated (w) + || (vpos >= w->current_matrix->nrows) + || !MATRIX_ROW_DISPLAYS_TEXT_P (MATRIX_ROW (w->current_matrix, + vpos))) + return; + + /* Get to the first glyph of a text row based on the vertical position + of the fringe. */ + struct glyph *glyph = MATRIX_ROW_GLYPH_START (w->current_matrix, vpos); + int glyph_num = MATRIX_ROW_USED (w->current_matrix, vpos); + + /* Check all glyphs while looking for fringe tooltips. */ + + /* NOTE: iterating over glyphs can only find text properties coming + from visible text. This means that zero-length overlays and + invisibile text are NOT inspected. */ + for (; glyph_num; glyph_num--, glyph++) + { + Lisp_Object pos = make_fixnum (glyph->charpos); + Lisp_Object help_echo = Qnil; + + if (STRINGP (glyph->object) || BUFFERP (glyph->object)) + help_echo = get_char_property_and_overlay (pos, sym, + glyph->object, NULL); + + if (STRINGP (help_echo)) + { + help_echo_string = help_echo; + break; + } + } +} + /* EXPORT: Take proper action when the mouse has moved to position X, Y on frame F with regards to highlighting portions of display that have @@ -35957,8 +36040,12 @@ note_mouse_highlight (struct frame *f, int x, int y) } else cursor = FRAME_OUTPUT_DATA (f)->nontext_cursor; - else if (part == ON_LEFT_FRINGE || part == ON_RIGHT_FRINGE - || part == ON_VERTICAL_SCROLL_BAR + else if (part == ON_LEFT_FRINGE || part == ON_RIGHT_FRINGE) + { + cursor = FRAME_OUTPUT_DATA (f)->nontext_cursor; + note_fringe_highlight (f, window, x, y, part); + } + else if (part == ON_VERTICAL_SCROLL_BAR || part == ON_HORIZONTAL_SCROLL_BAR) cursor = FRAME_OUTPUT_DATA (f)->nontext_cursor; else @@ -38173,6 +38260,16 @@ The default value is zero, which disables this feature. The recommended non-zero value is between 100000 and 1000000, depending on your patience and the speed of your system. */); max_redisplay_ticks = 0; + + /* Called by decode_mode_spec. */ + DEFSYM (Qfile_remote_p, "file-remote-p"); + + /* Called or compared against by various functions. */ + DEFSYM (Qmessages_buffer_mode, "messages-buffer-mode"); + DEFSYM (Qhdrag, "hdrag"); + DEFSYM (Qnhdrag, "nhdrag"); + DEFSYM (Qvdrag, "vdrag"); + DEFSYM (Qhourglass, "hourglass"); } diff --git a/src/xfaces.c b/src/xfaces.c index a558e7328c0..5192b22ce0a 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -504,7 +504,7 @@ void x_free_dpy_colors (Display *dpy, Screen *screen, Colormap cmap, unsigned long *pixels, int npixels) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); /* If display has an immutable color map, freeing colors is not necessary and some servers don't allow it. So don't do it. */ @@ -619,21 +619,7 @@ static struct android_gc * x_create_gc (struct frame *f, unsigned long value_mask, Emacs_GC *xgcv) { - struct android_gc_values gcv; - unsigned long mask; - - gcv.foreground = xgcv->foreground; - gcv.background = xgcv->background; - - mask = 0; - - if (value_mask & GCForeground) - mask |= ANDROID_GC_FOREGROUND; - - if (value_mask & GCBackground) - mask |= ANDROID_GC_BACKGROUND; - - return android_create_gc (mask, &gcv); + return android_create_gc (value_mask, xgcv); } static void @@ -1098,7 +1084,7 @@ tty_lookup_color (struct frame *f, Lisp_Object color, Emacs_Color *tty_color, return true; } - else if (NILP (Fsymbol_value (intern ("tty-defined-color-alist")))) + else if (NILP (Fsymbol_value (Qtty_defined_color_alist))) /* We were called early during startup, and the colors are not yet set up in tty-defined-color-alist. Don't return a failure indication, since this produces the annoying "Unable to @@ -3311,7 +3297,11 @@ FRAME 0 means change the face on all frames, and change the default } else if (EQ (key, QCstyle) - && !(EQ (val, Qline) || EQ (val, Qwave))) + && !(EQ (val, Qline) + || EQ (val, Qdouble_line) + || EQ (val, Qwave) + || EQ (val, Qdots) + || EQ (val, Qdashes))) { valid_p = false; break; @@ -4569,6 +4559,15 @@ free_realized_face (struct frame *f, struct face *face) /* Free fontset of FACE if it is ASCII face. */ if (face->fontset >= 0 && face == face->ascii_face) free_face_fontset (f, face); + +#ifdef HAVE_X_WINDOWS + /* This function might be called with the frame's display + connection deleted, in which event the callbacks below + should not be executed, as they generate X requests. */ + if (FRAME_X_DISPLAY (f)) + return; +#endif /* HAVE_X_WINDOWS */ + if (face->gc) { block_input (); @@ -4621,14 +4620,18 @@ prepare_face_for_display (struct frame *f, struct face *face) #endif block_input (); -#ifdef HAVE_X_WINDOWS +#if defined HAVE_X_WINDOWS || defined HAVE_ANDROID if (face->stipple) { egc.fill_style = FillOpaqueStippled; +#ifndef ANDROID_STUBIFY egc.stipple = image_bitmap_pixmap (f, face->stipple); +#else /* !ANDROID_STUBIFY */ + emacs_abort (); +#endif /* !ANDROID_STUBIFY */ mask |= GCFillStyle | GCStipple; } -#endif +#endif /* HAVE_X_WINDOWS || HAVE_ANDROID */ face->gc = x_create_gc (f, mask, &egc); if (face->font) font_prepare_for_face (f, face); @@ -5266,6 +5269,7 @@ gui_supports_face_attributes_p (struct frame *f, Lisp_Object attrs[LFACE_VECTOR_SIZE], struct face *def_face) { + Lisp_Object val; Lisp_Object *def_attrs = def_face->lface; Lisp_Object lattrs[LFACE_VECTOR_SIZE]; @@ -5360,6 +5364,14 @@ gui_supports_face_attributes_p (struct frame *f, return false; } + /* Check supported underline styles. */ + val = attrs[LFACE_UNDERLINE_INDEX]; + if (!UNSPECIFIEDP (val) + && EQ (CAR_SAFE (val), QCstyle) + && !(EQ (CAR_SAFE (CDR_SAFE (val)), Qline) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qwave))) + return false; /* Unsupported underline style. */ + /* Everything checks out, this face is supported. */ return true; } @@ -5453,9 +5465,18 @@ tty_supports_face_attributes_p (struct frame *f, if (!UNSPECIFIEDP (val)) { if (STRINGP (val)) - return false; /* ttys can't use colored underlines */ - else if (EQ (CAR_SAFE (val), QCstyle) && EQ (CAR_SAFE (CDR_SAFE (val)), Qwave)) - return false; /* ttys can't use wave underlines */ + test_caps |= TTY_CAP_UNDERLINE_STYLED; + else if (EQ (CAR_SAFE (val), QCstyle)) + { + if (!(EQ (CAR_SAFE (CDR_SAFE (val)), Qline) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qdouble_line) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qwave) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qdots) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qdashes))) + return false; /* Face uses an unsupported underline style. */ + + test_caps |= TTY_CAP_UNDERLINE_STYLED; + } else if (face_attr_equal_p (val, def_attrs[LFACE_UNDERLINE_INDEX])) return false; /* same as default */ else @@ -6312,7 +6333,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] if (EQ (underline, Qt)) { /* Use default color (same as foreground color). */ - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; face->underline_defaulted_p = true; face->underline_color = 0; face->underline_at_descent_line_p = false; @@ -6321,7 +6342,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] else if (STRINGP (underline)) { /* Use specified color. */ - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; face->underline_defaulted_p = false; face->underline_color = load_color (f, face, underline, @@ -6341,7 +6362,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] { /* `(:color COLOR :style STYLE)'. STYLE being one of `line' or `wave'. */ - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; face->underline_color = 0; face->underline_defaulted_p = true; face->underline_at_descent_line_p = false; @@ -6377,11 +6398,19 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] } else if (EQ (keyword, QCstyle)) { - if (EQ (value, Qline)) - face->underline = FACE_UNDER_LINE; - else if (EQ (value, Qwave)) - face->underline = FACE_UNDER_WAVE; - } + if (EQ (value, Qline)) + face->underline = FACE_UNDERLINE_SINGLE; + else if (EQ (value, Qdouble_line)) + face->underline = FACE_UNDERLINE_DOUBLE_LINE; + else if (EQ (value, Qwave)) + face->underline = FACE_UNDERLINE_WAVE; + else if (EQ (value, Qdots)) + face->underline = FACE_UNDERLINE_DOTS; + else if (EQ (value, Qdashes)) + face->underline = FACE_UNDERLINE_DASHES; + else + face->underline = FACE_UNDERLINE_SINGLE; + } else if (EQ (keyword, QCposition)) { face->underline_at_descent_line_p = !NILP (value); @@ -6431,17 +6460,18 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] } -/* Map a specified color of face FACE on frame F to a tty color index. - IDX is either LFACE_FOREGROUND_INDEX or LFACE_BACKGROUND_INDEX, and - specifies which color to map. Set *DEFAULTED to true if mapping to the +/* Map the specified color COLOR of face FACE on frame F to a tty + color index. IDX is one of LFACE_FOREGROUND_INDEX, + LFACE_BACKGROUND_INDEX or LFACE_UNDERLINE_INDEX, and specifies + which color to map. Set *DEFAULTED to true if mapping to the default foreground/background colors. */ static void -map_tty_color (struct frame *f, struct face *face, - enum lface_attribute_index idx, bool *defaulted) +map_tty_color (struct frame *f, struct face *face, Lisp_Object color, + enum lface_attribute_index idx, bool *defaulted) { - Lisp_Object frame, color, def; - bool foreground_p = idx == LFACE_FOREGROUND_INDEX; + Lisp_Object frame, def; + bool foreground_p = idx != LFACE_BACKGROUND_INDEX; unsigned long default_pixel = foreground_p ? FACE_TTY_DEFAULT_FG_COLOR : FACE_TTY_DEFAULT_BG_COLOR; unsigned long pixel = default_pixel; @@ -6450,10 +6480,11 @@ map_tty_color (struct frame *f, struct face *face, foreground_p ? FACE_TTY_DEFAULT_BG_COLOR : FACE_TTY_DEFAULT_FG_COLOR; #endif - eassert (idx == LFACE_FOREGROUND_INDEX || idx == LFACE_BACKGROUND_INDEX); + eassert (idx == LFACE_FOREGROUND_INDEX + || idx == LFACE_BACKGROUND_INDEX + || idx == LFACE_UNDERLINE_INDEX); XSETFRAME (frame, f); - color = face->lface[idx]; if (STRINGP (color) && SCHARS (color) @@ -6498,13 +6529,21 @@ map_tty_color (struct frame *f, struct face *face, #endif /* MSDOS */ } - if (foreground_p) - face->foreground = pixel; - else - face->background = pixel; + switch (idx) + { + case LFACE_FOREGROUND_INDEX: + face->foreground = pixel; + break; + case LFACE_UNDERLINE_INDEX: + face->underline_color = pixel; + break; + case LFACE_BACKGROUND_INDEX: + default: + face->background = pixel; + break; + } } - /* Realize the fully-specified face with attributes ATTRS in face cache CACHE for ASCII characters. Do it for TTY frame CACHE->f. Value is a pointer to the newly created realized face. */ @@ -6515,6 +6554,7 @@ realize_tty_face (struct face_cache *cache, { struct face *face; int weight, slant; + Lisp_Object underline; bool face_colors_defaulted = false; struct frame *f = cache->f; @@ -6534,16 +6574,83 @@ realize_tty_face (struct face_cache *cache, face->tty_bold_p = true; if (slant != 100) face->tty_italic_p = true; - if (!NILP (attrs[LFACE_UNDERLINE_INDEX])) - face->tty_underline_p = true; if (!NILP (attrs[LFACE_INVERSE_INDEX])) face->tty_reverse_p = true; if (!NILP (attrs[LFACE_STRIKE_THROUGH_INDEX])) face->tty_strike_through_p = true; + /* Text underline. */ + underline = attrs[LFACE_UNDERLINE_INDEX]; + if (NILP (underline)) + { + face->underline = FACE_NO_UNDERLINE; + face->underline_color = 0; + } + else if (EQ (underline, Qt)) + { + face->underline = FACE_UNDERLINE_SINGLE; + face->underline_color = 0; + } + else if (STRINGP (underline)) + { + face->underline = FACE_UNDERLINE_SINGLE; + bool underline_color_defaulted; + map_tty_color (f, face, underline, LFACE_UNDERLINE_INDEX, + &underline_color_defaulted); + } + else if (CONSP (underline)) + { + /* `(:color COLOR :style STYLE)'. + STYLE being one of `line', `double-line', `wave', `dots' or `dashes'. */ + face->underline = FACE_UNDERLINE_SINGLE; + face->underline_color = 0; + + while (CONSP (underline)) + { + Lisp_Object keyword, value; + + keyword = XCAR (underline); + underline = XCDR (underline); + + if (!CONSP (underline)) + break; + value = XCAR (underline); + underline = XCDR (underline); + + if (EQ (keyword, QCcolor)) + { + if (EQ (value, Qforeground_color)) + face->underline_color = 0; + else if (STRINGP (value)) + { + bool underline_color_defaulted; + map_tty_color (f, face, value, LFACE_UNDERLINE_INDEX, + &underline_color_defaulted); + } + } + else if (EQ (keyword, QCstyle)) + { + if (EQ (value, Qline)) + face->underline = FACE_UNDERLINE_SINGLE; + else if (EQ (value, Qdouble_line)) + face->underline = FACE_UNDERLINE_DOUBLE_LINE; + else if (EQ (value, Qwave)) + face->underline = FACE_UNDERLINE_WAVE; + else if (EQ (value, Qdots)) + face->underline = FACE_UNDERLINE_DOTS; + else if (EQ (value, Qdashes)) + face->underline = FACE_UNDERLINE_DASHES; + else + face->underline = FACE_UNDERLINE_SINGLE; + } + } + } + /* Map color names to color indices. */ - map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted); - map_tty_color (f, face, LFACE_BACKGROUND_INDEX, &face_colors_defaulted); + map_tty_color (f, face, face->lface[LFACE_FOREGROUND_INDEX], + LFACE_FOREGROUND_INDEX, &face_colors_defaulted); + map_tty_color (f, face, face->lface[LFACE_BACKGROUND_INDEX], + LFACE_BACKGROUND_INDEX, &face_colors_defaulted); /* Swap colors if face is inverse-video. If the colors are taken from the frame colors, they are already inverted, since the @@ -7229,6 +7336,9 @@ syms_of_xfaces (void) DEFSYM (QCposition, ":position"); DEFSYM (Qline, "line"); DEFSYM (Qwave, "wave"); + DEFSYM (Qdouble_line, "double-line"); + DEFSYM (Qdots, "dots"); + DEFSYM (Qdashes, "dashes"); DEFSYM (Qreleased_button, "released-button"); DEFSYM (Qpressed_button, "pressed-button"); DEFSYM (Qflat_button, "flat-button"); @@ -7298,6 +7408,7 @@ syms_of_xfaces (void) /* The name of the function used to compute colors on TTYs. */ DEFSYM (Qtty_color_alist, "tty-color-alist"); + DEFSYM (Qtty_defined_color_alist, "tty-defined-color-alist"); Vface_alternative_font_family_alist = Qnil; staticpro (&Vface_alternative_font_family_alist); diff --git a/src/xfns.c b/src/xfns.c index d610c839bfc..c48fa24b6be 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -3917,11 +3917,12 @@ xic_string_conversion_callback (XIC ic, XPointer client_data, return; failure: - /* Return a string of length 0 using the C library malloc. This + /* Return a string of length 0 using the C library malloc (1) + (not malloc (0), to pacify gcc -Walloc-size). This assumes XFree is able to free data allocated with our malloc wrapper. */ call_data->text->length = 0; - call_data->text->string.mbs = malloc (0); + call_data->text->string.mbs = malloc (1); } #endif /* HAVE_X_I18N */ @@ -6546,10 +6547,7 @@ void xlw_monitor_dimensions_at_pos (Display *dpy, Screen *screen, int src_x, int src_y, int *x, int *y, int *width, int *height) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - - if (!dpyinfo) - emacs_abort (); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); block_input (); xlw_monitor_dimensions_at_pos_1 (dpyinfo, screen, src_x, src_y, @@ -10213,10 +10211,7 @@ XkbFreeNames (XkbDescPtr xkb, unsigned int which, Bool free_map) int XDisplayCells (Display *dpy, int screen_number) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - - if (!dpyinfo) - emacs_abort (); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); /* Not strictly correct, since the display could be using a non-default visual, but it satisfies the callers we need to care diff --git a/src/xmenu.c b/src/xmenu.c index ef1eeb5925f..8682e67dad4 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -236,7 +236,7 @@ x_menu_translate_generic_event (XEvent *event) XEvent copy; XIDeviceEvent *xev; - dpyinfo = x_display_info_for_display (event->xgeneric.display); + dpyinfo = x_dpyinfo (event->xgeneric.display); if (event->xgeneric.extension == dpyinfo->xi2_opcode) { diff --git a/src/xml.c b/src/xml.c index 85f16746289..dc707bea864 100644 --- a/src/xml.c +++ b/src/xml.c @@ -165,7 +165,7 @@ make_dom (xmlNode *node) else if (node->type == XML_COMMENT_NODE) { if (node->content) - return list3 (intern ("comment"), Qnil, + return list3 (Qcomment, Qnil, build_string ((char *) node->content)); else return Qnil; @@ -353,4 +353,6 @@ syms_of_xml (void) defsubr (&Slibxml_parse_xml_region); #endif defsubr (&Slibxml_available_p); + + DEFSYM (Qcomment, "comment"); } diff --git a/src/xterm.c b/src/xterm.c index c0aef65ab66..33ef18d8da5 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2933,7 +2933,6 @@ x_dnd_free_toplevels (bool display_alive) unsigned long *prev_masks UNINIT; specpdl_ref count; Display *dpy UNINIT; - struct x_display_info *dpyinfo; if (!x_dnd_toplevels) /* Probably called inside an IO error handler. */ @@ -2995,25 +2994,21 @@ x_dnd_free_toplevels (bool display_alive) record_unwind_protect_ptr (xfree, destroy_windows); record_unwind_protect_ptr (xfree, prev_masks); - if (display_alive) + if (display_alive && n_windows) { - dpyinfo = x_display_info_for_display (dpy); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); - if (n_windows) - { - eassume (dpyinfo); - x_ignore_errors_for_next_request (dpyinfo, 0); + x_ignore_errors_for_next_request (dpyinfo, 0); - for (i = 0; i < n_windows; ++i) - { - XSelectInput (dpy, destroy_windows[i], prev_masks[i]); + for (i = 0; i < n_windows; ++i) + { + XSelectInput (dpy, destroy_windows[i], prev_masks[i]); #ifdef HAVE_XSHAPE - XShapeSelectInput (dpy, destroy_windows[i], None); + XShapeSelectInput (dpy, destroy_windows[i], None); #endif - } - - x_stop_ignoring_errors (dpyinfo); } + + x_stop_ignoring_errors (dpyinfo); } unbind_to (count, Qnil); @@ -6881,7 +6876,20 @@ x_draw_horizontal_wave (struct frame *f, GC gc, int x, int y, #endif -/* Return the struct x_display_info corresponding to DPY. */ +/* Return the struct x_display_info corresponding to DPY, + when it is guaranteed that one will correspond. */ + +struct x_display_info * +x_dpyinfo (Display *dpy) +{ + for (struct x_display_info *dpyinfo = x_display_list; ; + dpyinfo = dpyinfo->next) + if (dpyinfo->display == dpy) + return dpyinfo; +} + +/* Return the struct x_display_info corresponding to DPY, + or a null pointer if none corresponds. */ struct x_display_info * x_display_info_for_display (Display *dpy) @@ -8895,7 +8903,7 @@ x_frame_of_widget (Widget widget) Lisp_Object tail, frame; struct frame *f; - dpyinfo = x_display_info_for_display (XtDisplay (widget)); + dpyinfo = x_dpyinfo (XtDisplay (widget)); /* Find the top-level shell of the widget. Note that this function can be called when the widget is not yet realized, so XtWindow @@ -9089,8 +9097,7 @@ cvt_pixel_dtor (XtAppContext app, XrmValuePtr to, XtPointer closure, XrmValuePtr static const XColor * x_color_cells (Display *dpy, int *ncells) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - eassume (dpyinfo); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); if (dpyinfo->color_cells == NULL) { @@ -9365,16 +9372,13 @@ x_parse_color (struct frame *f, const char *color_name, static bool x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - bool rc; - - eassume (dpyinfo); - rc = XAllocColor (dpy, cmap, color) != 0; + struct x_display_info *dpyinfo = x_dpyinfo (dpy); + bool rc = XAllocColor (dpy, cmap, color) != 0; if (dpyinfo->visual_info.class == DirectColor) return rc; - if (rc == 0) + if (!rc) { /* If we got to this point, the colormap is full, so we're going to try and get the next closest color. The algorithm used is @@ -9477,8 +9481,7 @@ x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color) /* If allocation succeeded, and the allocated pixel color is not equal to a cached pixel color recorded earlier, there was a change in the colormap, so clear the color cache. */ - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - eassume (dpyinfo); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); if (dpyinfo->color_cells) { @@ -10735,10 +10738,10 @@ x_draw_stretch_glyph_string (struct glyph_string *s) } static void -x_get_scale_factor (Display *disp, int *scale_x, int *scale_y) +x_get_scale_factor (struct x_display_info *dpyinfo, + int *scale_x, int *scale_y) { - const int base_res = 96; - struct x_display_info * dpyinfo = x_display_info_for_display (disp); + int base_res = 96; *scale_x = *scale_y = 1; @@ -10764,12 +10767,12 @@ x_get_scale_factor (Display *disp, int *scale_x, int *scale_y) static void x_draw_underwave (struct glyph_string *s, int decoration_width) { - Display *display = FRAME_X_DISPLAY (s->f); - + struct x_display_info *dpyinfo; /* Adjust for scale/HiDPI. */ int scale_x, scale_y; - x_get_scale_factor (display, &scale_x, &scale_y); + dpyinfo = FRAME_DISPLAY_INFO (s->f); + x_get_scale_factor (dpyinfo, &scale_x, &scale_y); int wave_height = 3 * scale_y, wave_length = 2 * scale_x; @@ -10777,6 +10780,7 @@ x_draw_underwave (struct glyph_string *s, int decoration_width) x_draw_horizontal_wave (s->f, s->gc, s->x, s->ybase - wave_height + 3, decoration_width, wave_height, wave_length); #else /* not USE_CAIRO */ + Display *display; int dx, dy, x0, y0, width, x1, y1, x2, y2, xmax, thickness = scale_y;; bool odd; XRectangle wave_clip, string_clip, final_clip; @@ -10799,6 +10803,7 @@ x_draw_underwave (struct glyph_string *s, int decoration_width) if (!gui_intersect_rectangles (&wave_clip, &string_clip, &final_clip)) return; + display = dpyinfo->display; XSetClipRectangles (display, s->gc, 0, 0, &final_clip, 1, Unsorted); /* Draw the waves */ @@ -10831,6 +10836,97 @@ x_draw_underwave (struct glyph_string *s, int decoration_width) #endif /* not USE_CAIRO */ } +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto F + at a vertical offset of OFFSET from the position of the glyph string + S, with each segment SEGMENT pixels in length. */ + +static void +x_draw_dash (struct frame *f, struct glyph_string *s, int width, + char segment, int offset, int thickness) +{ +#ifndef USE_CAIRO + GC gc; + Display *display; + XGCValues gcv; + int y_center; + + /* Configure the GC, the dash pattern and a suitable offset. */ + gc = s->gc; + display = FRAME_X_DISPLAY (f); + + gcv.line_style = LineOnOffDash; + gcv.line_width = thickness; + XChangeGC (display, s->gc, GCLineStyle | GCLineWidth, &gcv); + XSetDashes (display, s->gc, s->x, &segment, 1); + + /* Offset the origin of the line by half the line width. */ + y_center = s->ybase + offset + thickness / 2; + XDrawLine (display, FRAME_X_DRAWABLE (f), gc, + s->x, y_center, s->x + width, y_center); + + /* Restore the initial line style. */ + gcv.line_style = LineSolid; + gcv.line_width = 1; + XChangeGC (display, s->gc, GCLineStyle | GCLineWidth, &gcv); +#else /* USE_CAIRO */ + cairo_t *cr; + double cr_segment, y_center; + + cr = x_begin_cr_clip (f, s->gc); + cr_segment = (double) segment; + y_center = s->ybase + offset + (thickness / 2.0); + + x_set_cr_source_with_gc_foreground (f, s->gc, false); + cairo_set_dash (cr, &cr_segment, 1, s->x); + cairo_set_line_width (cr, thickness); + cairo_move_to (cr, s->x, y_center); + cairo_line_to (cr, s->x + width, y_center); + cairo_stroke (cr); + x_end_cr_clip (f); +#endif /* USE_CAIRO */ +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, DECORATION_WIDTH in length, and + THICKNESS in height. */ + +static void +x_fill_underline (struct frame *f, struct glyph_string *s, + enum face_underline_type style, int position, + int decoration_width, int thickness) +{ + int segment; + char x_segment; + + segment = thickness * 3; + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + x_fill_rectangle (f, s->gc, s->x, s->ybase + position, + decoration_width, thickness, false); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + x_segment = min (segment, CHAR_MAX); + x_draw_dash (f, s, decoration_width, x_segment, position, + thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} /* Draw glyph string S. */ @@ -10957,7 +11053,7 @@ x_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (s->face->underline_defaulted_p) x_draw_underwave (s, decoration_width); @@ -10971,13 +11067,13 @@ x_draw_glyph_string (struct glyph_string *s) XSetForeground (display, s->gc, xgcv.foreground); } } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -11054,22 +11150,36 @@ x_draw_glyph_string (struct glyph_string *s) thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; s->underline_position = position; - y = s->ybase + position; - if (s->face->underline_defaulted_p) - x_fill_rectangle (s->f, s->gc, - s->x, y, decoration_width, thickness, - false); - else - { - Display *display = FRAME_X_DISPLAY (s->f); - XGCValues xgcv; - XGetGCValues (display, s->gc, GCForeground, &xgcv); - XSetForeground (display, s->gc, s->face->underline_color); - x_fill_rectangle (s->f, s->gc, - s->x, y, decoration_width, thickness, - false); - XSetForeground (display, s->gc, xgcv.foreground); - } + + { + Display *display = FRAME_X_DISPLAY (s->f); + XGCValues xgcv; + + if (!s->face->underline_defaulted_p) + { + XGetGCValues (display, s->gc, GCForeground, &xgcv); + XSetForeground (display, s->gc, s->face->underline_color); + } + + x_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + x_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); + } + + if (!s->face->underline_defaulted_p) + XSetForeground (display, s->gc, xgcv.foreground); + } } } /* Draw overline. */ @@ -11440,19 +11550,9 @@ XTflash (struct frame *f) int fd, rc; block_input (); - - if (FRAME_X_VISUAL_INFO (f)->class == TrueColor) - { - values.function = GXxor; - values.foreground = (FRAME_FOREGROUND_PIXEL (f) - ^ FRAME_BACKGROUND_PIXEL (f)); - - gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - GCFunction | GCForeground, &values); - } - else - gc = FRAME_X_OUTPUT (f)->normal_gc; - + values.function = GXinvert; + gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + GCFunction, &values); /* Get the height not including a menu bar widget. */ int height = FRAME_PIXEL_HEIGHT (f); @@ -11539,8 +11639,7 @@ XTflash (struct frame *f) flash_left, FRAME_INTERNAL_BORDER_WIDTH (f), width, height - 2 * FRAME_INTERNAL_BORDER_WIDTH (f)); - if (FRAME_X_VISUAL_INFO (f)->class == TrueColor) - XFreeGC (FRAME_X_DISPLAY (f), gc); + XFreeGC (FRAME_X_DISPLAY (f), gc); x_flush (f); unblock_input (); @@ -14500,12 +14599,7 @@ x_query_pointer (Display *dpy, Window w, Window *root_return, int *root_y_return, int *win_x_return, int *win_y_return, unsigned int *mask_return) { - struct x_display_info *dpyinfo; - - dpyinfo = x_display_info_for_display (dpy); - - if (!dpyinfo) - emacs_abort (); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); #ifdef HAVE_XINPUT2 return x_query_pointer_1 (dpyinfo, dpyinfo->client_pointer_device, @@ -14551,18 +14645,19 @@ x_query_pointer (Display *dpy, Window w, Window *root_return, `x', `y', `x_root' and `y_root'. This function should not access any other fields in EVENT without also initializing the corresponding fields in `bv' under the XI_ButtonPress and - XI_ButtonRelease labels inside `handle_one_xevent'. */ + XI_ButtonRelease labels inside `handle_one_xevent'. + + XI2 indicates that this click comes from XInput2 rather than core + event. */ static Lisp_Object x_construct_mouse_click (struct input_event *result, const XButtonEvent *event, - struct frame *f) + struct frame *f, bool xi2) { int x = event->x; int y = event->y; - /* Make the event type NO_EVENT; we'll change that when we decide - otherwise. */ result->kind = MOUSE_CLICK_EVENT; result->code = event->button - Button1; result->timestamp = event->time; @@ -14572,6 +14667,29 @@ x_construct_mouse_click (struct input_event *result, ? up_modifier : down_modifier)); + /* Convert pre-XInput2 wheel events represented as mouse-clicks. */ + if (!xi2) + { + Lisp_Object base + = Fcdr_safe (Fassq (make_fixnum (result->code + 1), + Fsymbol_value (Qmouse_wheel_buttons))); + int wheel + = (NILP (base) ? -1 + : BASE_EQ (base, Qwheel_down) ? 0 + : BASE_EQ (base, Qwheel_up) ? 1 + : BASE_EQ (base, Qwheel_left) ? 2 + : BASE_EQ (base, Qwheel_right) ? 3 + : -1); + if (wheel >= 0) + { + result->kind = (event->type != ButtonRelease ? NO_EVENT + : wheel & 2 ? HORIZ_WHEEL_EVENT : WHEEL_EVENT); + result->code = 0; /* Not used. */ + result->modifiers &= ~(up_modifier || down_modifier); + result->modifiers |= wheel & 1 ? up_modifier : down_modifier; + } + } + /* If result->window is not the frame's edit widget (which can happen with GTK+ scroll bars, for example), translate the coordinates so they appear at the correct position. */ @@ -21881,13 +21999,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, && event->xbutton.time > ignore_next_mouse_click_timeout) { ignore_next_mouse_click_timeout = 0; - x_construct_mouse_click (&inev.ie, &event->xbutton, f); + x_construct_mouse_click (&inev.ie, &event->xbutton, + f, false); } if (event->type == ButtonRelease) ignore_next_mouse_click_timeout = 0; } else - x_construct_mouse_click (&inev.ie, &event->xbutton, f); + x_construct_mouse_click (&inev.ie, &event->xbutton, f, false); *finish = X_EVENT_DROP; goto OTHER; @@ -21957,13 +22076,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, && event->xbutton.time > ignore_next_mouse_click_timeout) { ignore_next_mouse_click_timeout = 0; - x_construct_mouse_click (&inev.ie, &event->xbutton, f); + x_construct_mouse_click (&inev.ie, &event->xbutton, + f, false); } if (event->type == ButtonRelease) ignore_next_mouse_click_timeout = 0; } else - x_construct_mouse_click (&inev.ie, &event->xbutton, f); + x_construct_mouse_click (&inev.ie, &event->xbutton, + f, false); if (!NILP (tab_bar_arg)) inev.ie.arg = tab_bar_arg; @@ -23740,13 +23861,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, && xev->time > ignore_next_mouse_click_timeout) { ignore_next_mouse_click_timeout = 0; - x_construct_mouse_click (&inev.ie, &bv, f); + x_construct_mouse_click (&inev.ie, &bv, f, true); } if (xev->evtype == XI_ButtonRelease) ignore_next_mouse_click_timeout = 0; } else - x_construct_mouse_click (&inev.ie, &bv, f); + x_construct_mouse_click (&inev.ie, &bv, f, true); if (!NILP (tab_bar_arg)) inev.ie.arg = tab_bar_arg; @@ -29401,6 +29522,17 @@ x_free_frame_resources (struct frame *f) xi_unlink_touch_points (f); #endif + /* We must free faces before destroying windows because some + font-driver (e.g. xft) access a window while finishing a face. + + This function must be called to remove this frame's fontsets from + Vfontset_list, and is itself responsible for not issuing X requests + if the connection has already been terminated. Otherwise, a future + call to a function that iterates over all existing fontsets might + crash, as they are not prepared to receive dead frames. + (bug#66151) */ + free_frame_faces (f); + /* If a display connection is dead, don't try sending more commands to the X server. */ if (dpyinfo->display) @@ -29410,10 +29542,6 @@ x_free_frame_resources (struct frame *f) if (f->pointer_invisible) XTtoggle_invisible_pointer (f, 0); - /* We must free faces before destroying windows because some - font-driver (e.g. xft) access a window while finishing a - face. */ - free_frame_faces (f); tear_down_x_back_buffer (f); if (f->output_data.x->icon_desc) @@ -32441,9 +32569,6 @@ syms_of_xterm (void) x_dnd_unsupported_drop_data = Qnil; staticpro (&x_dnd_unsupported_drop_data); - /* Used by x_cr_export_frames. */ - DEFSYM (Qconcat, "concat"); - DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms"); DEFSYM (Qlatin_1, "latin-1"); DEFSYM (Qnow, "now"); @@ -32452,6 +32577,12 @@ syms_of_xterm (void) DEFSYM (Qexpose, "expose"); DEFSYM (Qdont_save, "dont-save"); + DEFSYM (Qmouse_wheel_buttons, "mouse-wheel-buttons"); + DEFSYM (Qwheel_up, "wheel-up"); + DEFSYM (Qwheel_down, "wheel-down"); + DEFSYM (Qwheel_left, "wheel-left"); + DEFSYM (Qwheel_right, "wheel-right"); + #ifdef USE_GTK xg_default_icon_file = build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg"); staticpro (&xg_default_icon_file); @@ -32543,6 +32674,10 @@ Android does not support scroll bars at all. */); DEFSYM (Qraise_and_focus, "raise-and-focus"); DEFSYM (Qreally_fast, "really-fast"); + /* Referenced in gtkutil.c. */ + DEFSYM (Qtheme_name, "theme-name"); + DEFSYM (Qfile_name_sans_extension, "file-name-sans-extension"); + DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, doc: /* Which modifer value Emacs reports when Ctrl is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or diff --git a/src/xterm.h b/src/xterm.h index 2c00b1e7bec..437ef281b0c 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -993,6 +993,8 @@ extern int popup_activated_flag; /* This is a chain of structures for all the X displays currently in use. */ extern struct x_display_info *x_display_list; +extern struct x_display_info *x_dpyinfo (Display *) + ATTRIBUTE_RETURNS_NONNULL; extern struct x_display_info *x_display_info_for_display (Display *); extern struct frame *x_top_window_to_frame (struct x_display_info *, int); extern struct x_display_info *x_term_init (Lisp_Object, char *, char *); diff --git a/src/xwidget.c b/src/xwidget.c index 389c48ca7f5..04ebcbfe96c 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2286,7 +2286,7 @@ store_xwidget_download_callback_event (struct xwidget *xw, EVENT_INIT (event); event.kind = XWIDGET_EVENT; event.frame_or_window = Qnil; - event.arg = list5 (intern ("download-callback"), + event.arg = list5 (Qdownload_callback, xwl, build_string (url), build_string (mimetype), @@ -2305,7 +2305,7 @@ store_xwidget_js_callback_event (struct xwidget *xw, EVENT_INIT (event); event.kind = XWIDGET_EVENT; event.frame_or_window = Qnil; - event.arg = list4 (intern ("javascript-callback"), xwl, proc, argument); + event.arg = list4 (Qjavascript_callback, xwl, proc, argument); kbd_buffer_store_event (&event); } @@ -4001,6 +4001,8 @@ to take effect. */); staticpro (&dummy_tooltip_string); #endif #endif + DEFSYM (Qdownload_callback, "download-callback"); + DEFSYM (Qjavascript_callback, "javascript-callback"); } diff --git a/test/README b/test/README index 7a3cf871a57..fb9f45490c5 100644 --- a/test/README +++ b/test/README @@ -109,6 +109,12 @@ debugging. To do that, use make TEST_INTERACTIVE=yes ... +Sometimes, some further settings are needed in order to run the batch +test. This can be indicated by the $EMACS_EXTRAOPT environment +variable, like + + make ... EMACS_EXTRAOPT="--eval '(setopt ert-batch-print-length nil ert-batch-print-level nil)'" + By default, ERT test failure summaries are quite brief in batch mode--only the names of the failed tests are listed. If the $EMACS_TEST_VERBOSE environment variable is set and non-empty, the diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index d79072b06b5..088df86ad70 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -29,7 +29,7 @@ FROM debian:bullseye as emacs-base RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo gdb \ + libxml2-dev libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* FROM emacs-base as emacs-inotify @@ -45,7 +45,7 @@ WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure # 'make -j4 bootstrap' does not work reliably. -RUN make bootstrap +RUN make -j `nproc` bootstrap FROM emacs-base as emacs-filenotify-gio @@ -58,7 +58,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-file-notification=gfile -RUN make bootstrap +RUN make -j `nproc` bootstrap # Debian bullseye doesn't provide proper packages. So we use Debian # sid for this. @@ -68,20 +68,49 @@ FROM debian:sid as emacs-eglot RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo gdb \ + libxml2-dev libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* -# Install clangd. +# Install clangd, tsserver. RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ - clangd \ + clangd node-typescript \ && rm -rf /var/lib/apt/lists/* +# eclipse-jdt-ls is planned as Java language server. +# See <https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1024246>. + +# The following LSP servers exist as snap packages. However, snap +# cannot be used inside containers. We keep this here for reference. + +# # Install snapd. +# RUN apt-get update && \ +# apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ +# snapd \ +# && rm -rf /var/lib/apt/lists/* +# RUN snap install core + +# # Install rust-analyzer. +# RUN snap install rust-analyzer --beta + +# # Install typescript-language-server. +# RUN snap install typescript-language-server + +# # Install vscode-json-languageserver. +# RUN snap install vscode-json-languageserver + COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure -RUN make bootstrap +RUN make -j `nproc` bootstrap + +# # Install company and yasnippet. +# RUN mkdir /root/.emacs.d +# RUN src/emacs --batch \ +# --eval '(setq url-debug 0 debug-on-error t)' \ +# --eval '(package-install (quote company))' \ +# --eval '(package-install (quote yasnippet))' # Debian bullseye doesn't provide proper packages. So we use Debian # sid for this. @@ -91,7 +120,7 @@ FROM debian:sid as emacs-tree-sitter RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo gdb \ + libxml2-dev libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* # Install tree-sitter library. @@ -104,7 +133,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-tree-sitter -RUN make bootstrap +RUN make -j `nproc` bootstrap # Install language grammars. RUN mkdir -p /root/.emacs.d/tree-sitter @@ -129,6 +158,7 @@ RUN src/emacs -Q --batch \ (lua "https://github.com/tree-sitter-grammars/tree-sitter-lua") \ (python "https://github.com/tree-sitter/tree-sitter-python") \ (ruby "https://github.com/tree-sitter/tree-sitter-ruby") \ + (rust "https://github.com/tree-sitter/tree-sitter-rust") \ (tsx "https://github.com/tree-sitter/tree-sitter-typescript" "master" "tsx/src") \ (typescript "https://github.com/tree-sitter/tree-sitter-typescript" "master" "typescript/src"))))' \ --eval '(dolist (lang (mapcar (quote car) treesit-language-source-alist)) \ @@ -145,7 +175,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-ns -RUN make bootstrap +RUN make -j `nproc` bootstrap FROM emacs-base as emacs-native-comp @@ -161,7 +191,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make bootstrap -j2 \ +RUN make -j `nproc` bootstrap \ NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' FROM emacs-native-comp as emacs-native-comp-speed1 @@ -170,7 +200,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make bootstrap -j2 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' +RUN make -j `nproc` bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' FROM emacs-native-comp as emacs-native-comp-speed2 @@ -178,4 +208,4 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make bootstrap -j2 +RUN make -j `nproc` bootstrap diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index 5ae32e7e005..9c32fd6a192 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -76,6 +76,15 @@ define subdir_template define changes @echo ' - lisp/so-long*.el' >>$(FILE) endef + else ifeq ($(findstring textmodes, $(1)), textmodes) + define changes + @echo ' - $(1)/*-ts-mode.el' >>$(FILE) + @echo ' - test/$(1)/*-ts-mode-resources/**' >>$(FILE) + @echo ' - test/$(1)/*-ts-mode-tests.el' >>$(FILE) + @echo ' when: never' >>$(FILE) + @echo ' - changes:' >>$(FILE) + @echo ' - $(1)/*.el' >>$(FILE) + endef else ifeq ($(findstring misc, $(1)), misc) define changes @echo ' - admin/*.el' >>$(FILE) @@ -103,13 +112,15 @@ define subdir_template @echo ' - test/$(1)/*.el' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' target: emacs-inotify' >>$(FILE) - @echo ' make_params: "-k -C test $(target)"' >>$(FILE) + @echo ' make_params: -C test $(target)' >>$(FILE) endef $(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) +# js-tests.el and python-tests.el don't follow test file name convention. TREE-SITTER-FILES ?= $(shell cd .. ; \ - find lisp src \( -name "*-ts-mode-tests.el" -o -name "treesit-tests.el" \) | \ + find lisp src \( -name "*-ts-mode-tests.el" -o -name "treesit-tests.el" \ + -o -name "js-tests.el" -o -name "python-tests.el" \) | \ sort | sed s/\\.el/.log/) all: generate-test-jobs @@ -120,6 +131,7 @@ generate-test-jobs: $(FILE) $(SUBDIR_TARGETS) tree-sitter-files-template tree-sitter-files-template: @echo >>$(FILE) + @echo "# js-tests.el and python-tests.el don't follow test file name convention." >>$(FILE) @echo '.tree-sitter-files-template:' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' tree_sitter_files: >-' >>$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 5299aee746b..11ff0d1c738 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -86,13 +86,14 @@ default: # TODO: with make -j4 several of the tests were failing, for # example shadowfile-tests, but passed without it. - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -xvc "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} -e NPROC=`nproc` --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -xvc "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j \$NPROC && make -k -j \$NPROC ${make_params}"' after_script: # - docker ps -a # - printenv # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} + - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/configure.log ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - find ${test_name} ! \( -name "*.log" -o -name ${EMACS_TEST_JUNIT_REPORT} \) -type f -delete # BusyBox find does not know -empty. @@ -183,9 +184,18 @@ default: changes: - "**.in" - lisp/progmodes/*-ts-mode.el + - lisp/progmodes/js.el + - lisp/progmodes/python.el + - lisp/textmodes/*-ts-mode.el + - src/treesit.{h,c} - test/infra/* - test/lisp/progmodes/*-ts-mode-resources/** - test/lisp/progmodes/*-ts-mode-tests.el + - test/lisp/progmodes/js-tests.el + - test/lisp/progmodes/python-tests.el + - test/lisp/textmodes/*-ts-mode-resources/** + - test/lisp/textmodes/*-ts-mode-tests.el + - test/src/treesit-tests.el .native-comp-template: rules: @@ -248,7 +258,10 @@ test-filenotify-gio: variables: target: emacs-filenotify-gio # This is needed in order to get a JUnit test report. - make_params: '-k -C test check-expensive LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log"' + make_params: >- + check-expensive + TEST_HOME=/root + LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log" build-image-eglot: stage: platform-images @@ -265,7 +278,13 @@ test-eglot: variables: target: emacs-eglot # This is needed in order to get a JUnit test report. - make_params: '-k -C test check-expensive LOGFILES="lisp/progmodes/eglot-tests.log"' + make_params: >- + check-expensive + TEST_HOME=/root LOGFILES="lisp/progmodes/eglot-tests.log" + # EMACS_EXTRAOPT="--eval \(package-reinstall\ \(quote\ company\)\) + # --eval \(package-reinstall\ \(quote\ yasnippet\)\) + # --eval \(use-package\ company\) + # --eval \(use-package\ yasnippet\)" build-image-tree-sitter: stage: platform-images @@ -281,8 +300,11 @@ test-tree-sitter: optional: true variables: target: emacs-tree-sitter + selector: >- + \(and\ \$\{SELECTOR_EXPENSIVE\}\ \(or\ \\\"^treesit\\\"\ \\\"-ts-\\\"\)\) # This is needed in order to get a JUnit test report. - make_params: '-k -C test check-expensive TEST_HOME=/root LOGFILES="$tree_sitter_files"' + make_params: >- + check SELECTOR=$selector TEST_HOME=/root LOGFILES="$tree_sitter_files" build-image-gnustep: stage: platform-images @@ -330,7 +352,7 @@ test-native-comp-speed2: optional: true variables: target: emacs-native-comp-speed2 - make_params: "-k -C test check SELECTOR='(not (tag :unstable))'" + make_params: check SELECTOR='(not (tag :unstable))' # Local Variables: # add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 1f5d607eda4..0d9cbb029e5 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -15,7 +15,7 @@ test-lib-src-inotify: - test/lib-src/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lib-src" + make_params: -C test check-lib-src test-lisp-inotify: stage: normal @@ -32,7 +32,7 @@ test-lisp-inotify: - test/lisp/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp" + make_params: -C test check-lisp test-lisp-calc-inotify: stage: normal @@ -49,7 +49,7 @@ test-lisp-calc-inotify: - test/lisp/calc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-calc" + make_params: -C test check-lisp-calc test-lisp-calendar-inotify: stage: normal @@ -66,7 +66,7 @@ test-lisp-calendar-inotify: - test/lisp/calendar/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-calendar" + make_params: -C test check-lisp-calendar test-lisp-cedet-inotify: stage: normal @@ -83,7 +83,7 @@ test-lisp-cedet-inotify: - test/lisp/cedet/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet" + make_params: -C test check-lisp-cedet test-lisp-cedet-semantic-inotify: stage: normal @@ -100,7 +100,7 @@ test-lisp-cedet-semantic-inotify: - test/lisp/cedet/semantic/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet-semantic" + make_params: -C test check-lisp-cedet-semantic test-lisp-cedet-semantic-bovine-inotify: stage: normal @@ -117,7 +117,7 @@ test-lisp-cedet-semantic-bovine-inotify: - test/lisp/cedet/semantic/bovine/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet-semantic-bovine" + make_params: -C test check-lisp-cedet-semantic-bovine test-lisp-cedet-srecode-inotify: stage: normal @@ -134,7 +134,7 @@ test-lisp-cedet-srecode-inotify: - test/lisp/cedet/srecode/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet-srecode" + make_params: -C test check-lisp-cedet-srecode test-lisp-emacs-lisp-inotify: stage: normal @@ -151,7 +151,7 @@ test-lisp-emacs-lisp-inotify: - test/lisp/emacs-lisp/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emacs-lisp" + make_params: -C test check-lisp-emacs-lisp test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal @@ -168,7 +168,7 @@ test-lisp-emacs-lisp-eieio-tests-inotify: - test/lisp/emacs-lisp/eieio-tests/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emacs-lisp-eieio-tests" + make_params: -C test check-lisp-emacs-lisp-eieio-tests test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal @@ -185,7 +185,7 @@ test-lisp-emacs-lisp-faceup-tests-inotify: - test/lisp/emacs-lisp/faceup-tests/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emacs-lisp-faceup-tests" + make_params: -C test check-lisp-emacs-lisp-faceup-tests test-lisp-emulation-inotify: stage: normal @@ -202,7 +202,7 @@ test-lisp-emulation-inotify: - test/lisp/emulation/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emulation" + make_params: -C test check-lisp-emulation test-lisp-erc-inotify: stage: normal @@ -219,7 +219,7 @@ test-lisp-erc-inotify: - test/lisp/erc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-erc" + make_params: -C test check-lisp-erc test-lisp-eshell-inotify: stage: normal @@ -236,7 +236,7 @@ test-lisp-eshell-inotify: - test/lisp/eshell/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-eshell" + make_params: -C test check-lisp-eshell test-lisp-gnus-inotify: stage: normal @@ -253,7 +253,7 @@ test-lisp-gnus-inotify: - test/lisp/gnus/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-gnus" + make_params: -C test check-lisp-gnus test-lisp-image-inotify: stage: normal @@ -270,7 +270,7 @@ test-lisp-image-inotify: - test/lisp/image/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-image" + make_params: -C test check-lisp-image test-lisp-international-inotify: stage: normal @@ -287,7 +287,7 @@ test-lisp-international-inotify: - test/lisp/international/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-international" + make_params: -C test check-lisp-international test-lisp-mail-inotify: stage: normal @@ -304,7 +304,7 @@ test-lisp-mail-inotify: - test/lisp/mail/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-mail" + make_params: -C test check-lisp-mail test-lisp-mh-e-inotify: stage: normal @@ -321,7 +321,7 @@ test-lisp-mh-e-inotify: - test/lisp/mh-e/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-mh-e" + make_params: -C test check-lisp-mh-e test-lisp-net-inotify: stage: normal @@ -338,7 +338,7 @@ test-lisp-net-inotify: - test/lisp/net/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-net" + make_params: -C test check-lisp-net test-lisp-nxml-inotify: stage: normal @@ -355,7 +355,7 @@ test-lisp-nxml-inotify: - test/lisp/nxml/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-nxml" + make_params: -C test check-lisp-nxml test-lisp-obsolete-inotify: stage: normal @@ -372,7 +372,7 @@ test-lisp-obsolete-inotify: - test/lisp/obsolete/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-obsolete" + make_params: -C test check-lisp-obsolete test-lisp-org-inotify: stage: normal @@ -389,7 +389,7 @@ test-lisp-org-inotify: - test/lisp/org/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-org" + make_params: -C test check-lisp-org test-lisp-play-inotify: stage: normal @@ -406,7 +406,7 @@ test-lisp-play-inotify: - test/lisp/play/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-play" + make_params: -C test check-lisp-play test-lisp-progmodes-inotify: stage: normal @@ -430,7 +430,7 @@ test-lisp-progmodes-inotify: - test/lisp/progmodes/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-progmodes" + make_params: -C test check-lisp-progmodes test-lisp-so-long-tests-inotify: stage: normal @@ -447,7 +447,7 @@ test-lisp-so-long-tests-inotify: - test/lisp/so-long-tests/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-so-long-tests" + make_params: -C test check-lisp-so-long-tests test-lisp-term-inotify: stage: normal @@ -464,7 +464,7 @@ test-lisp-term-inotify: - test/lisp/term/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-term" + make_params: -C test check-lisp-term test-lisp-textmodes-inotify: stage: normal @@ -476,12 +476,17 @@ test-lisp-textmodes-inotify: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: + - lisp/textmodes/*-ts-mode.el + - test/lisp/textmodes/*-ts-mode-resources/** + - test/lisp/textmodes/*-ts-mode-tests.el + when: never + - changes: - lisp/textmodes/*.el - test/lisp/textmodes/*resources/** - test/lisp/textmodes/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-textmodes" + make_params: -C test check-lisp-textmodes test-lisp-url-inotify: stage: normal @@ -498,7 +503,7 @@ test-lisp-url-inotify: - test/lisp/url/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-url" + make_params: -C test check-lisp-url test-lisp-use-package-inotify: stage: normal @@ -515,7 +520,7 @@ test-lisp-use-package-inotify: - test/lisp/use-package/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-use-package" + make_params: -C test check-lisp-use-package test-lisp-vc-inotify: stage: normal @@ -532,7 +537,7 @@ test-lisp-vc-inotify: - test/lisp/vc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-vc" + make_params: -C test check-lisp-vc test-misc-inotify: stage: normal @@ -549,7 +554,7 @@ test-misc-inotify: - test/misc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-misc" + make_params: -C test check-misc test-src-inotify: stage: normal @@ -570,8 +575,9 @@ test-src-inotify: - test/src/*.el variables: target: emacs-inotify - make_params: "-k -C test check-src" + make_params: -C test check-src +# js-tests.el and python-tests.el don't follow test file name convention. .tree-sitter-files-template: variables: tree_sitter_files: >- @@ -580,7 +586,10 @@ test-src-inotify: lisp/progmodes/go-ts-mode-tests.log lisp/progmodes/heex-ts-mode-tests.log lisp/progmodes/java-ts-mode-tests.log + lisp/progmodes/js-tests.log lisp/progmodes/lua-ts-mode-tests.log + lisp/progmodes/python-tests.log lisp/progmodes/ruby-ts-mode-tests.log + lisp/progmodes/rust-ts-mode-tests.log lisp/progmodes/typescript-ts-mode-tests.log src/treesit-tests.log diff --git a/test/lisp/align-tests.el b/test/lisp/align-tests.el index cd309ea07bf..eaebaf8360c 100644 --- a/test/lisp/align-tests.el +++ b/test/lisp/align-tests.el @@ -52,7 +52,7 @@ (autoload 'treesit-ready-p "treesit") (ert-deftest align-lua () - (skip-unless (treesit-ready-p 'lua)) + (skip-unless (treesit-ready-p 'lua t)) (let ((comment-column 20) (indent-tabs-mode nil)) (ert-test-erts-file (ert-resource-file "lua-ts-mode.erts") diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 39ad735a789..32c06cbc533 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -368,6 +368,9 @@ END:VTIMEZONE (icalendar--datestring-to-isodate "2008 05 31"))) (should (string= "20080602" (icalendar--datestring-to-isodate "2008 05 31" 2))) + ;; Bug#69894 + (should (string= "20240319" + (icalendar--datestring-to-isodate "2024-03-19"))) ;; numeric european (setq calendar-date-style 'european) diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 01f9f8a5108..6512dd0bd07 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -100,7 +100,10 @@ (should (equal (format-seconds "%hh %z%x%mm %ss" (* 60 2)) "2m")) (should (equal (format-seconds "%hh %z%mm %ss" (* 60 2)) "2m 0s")) (should (equal (format-seconds "%hh %x%mm %ss" (* 60 2)) "0h 2m")) - (should (equal (format-seconds "%hh %x%mm %ss" 0) "0h 0m 0s"))) + (should (equal (format-seconds "%hh %x%mm %ss" 0) "0h 0m 0s")) + ;; Bug#70322 + (should (equal (format-seconds "%y %z%d %h %m %s %%" 9999999) "115 17 46 39 %")) + (should (equal (format-seconds "%Y, %D, %H, %M, %z%S" 0) "0 seconds"))) (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el index 5b2c28bd3dd..7d358d07519 100644 --- a/test/lisp/completion-preview-tests.el +++ b/test/lisp/completion-preview-tests.el @@ -27,23 +27,25 @@ (when-let ((bounds (bounds-of-thing-at-point 'symbol))) (append (list (car bounds) (cdr bounds) completions) props)))) -(defun completion-preview-tests--check-preview (string &optional exact) +(defun completion-preview-tests--check-preview + (string &optional beg-face end-face) "Check that the completion preview is showing STRING. -If EXACT is non-nil, check that STRING has the -`completion-preview-exact' face. Otherwise check that STRING has -the `completion-preview' face. +BEG-FACE and END-FACE say which faces the beginning and end of STRING +should have, respectively. Both BEG-FACE and END-FACE default to +`completion-preview'. If STRING is nil, check that there is no completion preview instead." (if (not string) - (should (not completion-preview--overlay)) + (should-not completion-preview--overlay) (should completion-preview--overlay) (let ((after-string (completion-preview--get 'after-string))) (should (string= after-string string)) (should (eq (get-text-property 0 'face after-string) - (if exact - 'completion-preview-exact + (or beg-face 'completion-preview))) + (should (eq (get-text-property (1- (length after-string)) 'face after-string) + (or end-face 'completion-preview)))))) (ert-deftest completion-preview () @@ -57,7 +59,9 @@ instead." (completion-preview--post-command)) ;; Exact match - (completion-preview-tests--check-preview "barbaz" 'exact) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact) (insert "v") (let ((this-command 'self-insert-command)) @@ -71,7 +75,9 @@ instead." (completion-preview--post-command)) ;; Exact match again - (completion-preview-tests--check-preview "barbaz" 'exact))) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-multiple-matches () "Test Completion Preview mode with multiple matching candidates." @@ -84,12 +90,12 @@ instead." (completion-preview--post-command)) ;; Multiple matches, the preview shows the first one - (completion-preview-tests--check-preview "bar") + (completion-preview-tests--check-preview "bar" 'completion-preview-common) (completion-preview-next-candidate 1) ;; Next match - (completion-preview-tests--check-preview "baz"))) + (completion-preview-tests--check-preview "baz" 'completion-preview-common))) (ert-deftest completion-preview-exact-match-only () "Test `completion-preview-exact-match-only'." @@ -111,7 +117,9 @@ instead." (completion-preview--post-command)) ;; Exact match - (completion-preview-tests--check-preview "m" 'exact))) + (completion-preview-tests--check-preview "m" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-function-capfs () "Test Completion Preview mode with capfs that return a function." @@ -124,7 +132,7 @@ instead." (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "bar"))) + (completion-preview-tests--check-preview "bar" 'completion-preview-common))) (ert-deftest completion-preview-non-exclusive-capfs () "Test Completion Preview mode with non-exclusive capfs." @@ -140,11 +148,13 @@ instead." (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "bar") + (completion-preview-tests--check-preview "bar" 'completion-preview-common) (setq-local completion-preview-exact-match-only t) (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "barbaz" 'exact))) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-face-updates () "Test updating the face in completion preview when match is no longer exact." @@ -160,7 +170,9 @@ instead." (insert "b") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "arbaz" 'exact) + (completion-preview-tests--check-preview "arbaz" + 'completion-preview-exact + 'completion-preview-exact) (delete-char -1) (let ((this-command 'delete-backward-char)) (completion-preview--post-command)) @@ -173,13 +185,15 @@ instead." (with-temp-buffer (setq-local completion-at-point-functions (list - (lambda () (user-error "bad")) + (lambda () (user-error "Bad")) (completion-preview-tests--capf '("foobarbaz")))) (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "barbaz" 'exact))) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-mid-symbol-cycle () "Test cycling the completion preview with point at the middle of a symbol." @@ -196,4 +210,101 @@ instead." (completion-preview-next-candidate 1) (completion-preview-tests--check-preview "z"))) +(ert-deftest completion-preview-complete () + "Test `completion-preview-complete'." + (with-temp-buffer + (let ((exit-fn-called nil) + (exit-fn-args nil) + (message-args nil) + (completion-auto-help nil)) + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foobar" "foobaz" "foobash" "foobash-mode") + :exit-function + (lambda (&rest args) + (setq exit-fn-called t + exit-fn-args args))))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (message "here") + + (completion-preview-tests--check-preview "bar" 'completion-preview-common) + + ;; Insert the common prefix, "ba". + (completion-preview-complete) + + ;; Only "r" should remain. + (completion-preview-tests--check-preview "r") + + (cl-letf (((symbol-function #'minibuffer-message) + (lambda (&rest args) (setq message-args args)))) + + ;; With `completion-auto-help' set to nil, a second call to + ;; `completion-preview-complete' just displays a message. + (completion-preview-complete) + (setq completion-preview--inhibit-update-p nil) + + (should (equal message-args '("Next char not unique")))) + + ;; The preview should stay put. + (completion-preview-tests--check-preview "r") + ;; (completion-preview-active-mode -1) + + ;; Narrow further. + (insert "s") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; The preview should indicate an exact match. + (completion-preview-tests--check-preview "h" + 'completion-preview-common + 'completion-preview-common) + + ;; Insert the entire preview content. + (completion-preview-complete) + (setq completion-preview--inhibit-update-p nil) + (let ((this-command 'completion-preview-complete)) + (completion-preview--post-command)) + + ;; The preview should update to indicate that there's a further + ;; possible completion. + (completion-preview-tests--check-preview "-mode" + 'completion-preview-exact + 'completion-preview-exact) + (should exit-fn-called) + (should (equal exit-fn-args '("foobash" exact))) + (setq exit-fn-called nil exit-fn-args nil) + + ;; Insert the extra suffix. + (completion-preview-complete) + + ;; Nothing more to show, so the preview should now be gone. + (should-not completion-preview--overlay) + (should exit-fn-called) + (should (equal exit-fn-args '("foobash-mode" finished)))))) + +(ert-deftest completion-preview-insert-calls-exit-function () + "Test that `completion-preview-insert' calls the completion exit function." + (let ((exit-fn-called nil) (exit-fn-args nil)) + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foobar" "foobaz") + :exit-function + (lambda (&rest args) + (setq exit-fn-called t + exit-fn-args args))))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "bar" 'completion-preview-common) + (completion-preview-insert) + (should (string= (buffer-string) "foobar")) + (should-not completion-preview--overlay) + (should exit-fn-called) + (should (equal exit-fn-args '("foobar" finished)))))) + ;;; completion-preview-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 26408e8685a..e3ce87cc9af 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1135,7 +1135,7 @@ byte-compiled. Run with dynamic binding." "var.*foo.*lacks a prefix") (bytecomp--define-warning-file-test "warn-format.el" - "called with 2 args to fill 1 format field") + "called with 2 arguments to fill 1 format field") (bytecomp--define-warning-file-test "warn-free-setq.el" "free.*foo") @@ -1348,12 +1348,14 @@ byte-compiled. Run with dynamic binding." (string-search "file has no `lexical-binding' directive on its first line" (bytecomp-tests--log-from-compilation source)))) - (let ((some-code "(defun my-fun () 12)\n")) - (should-not (cookie-warning - (concat ";;; -*-lexical-binding:t-*-\n" some-code))) - (should-not (cookie-warning - (concat ";;; -*-lexical-binding:nil-*-\n" some-code))) - (should (cookie-warning some-code))))) + (dolist (lb '(t nil)) + (let ((lexical-binding lb) + (some-code "(defun my-fun () 12)\n")) + (should-not (cookie-warning + (concat ";;; -*-lexical-binding:t-*-\n" some-code))) + (should-not (cookie-warning + (concat ";;; -*-lexical-binding:nil-*-\n" some-code))) + (should (cookie-warning some-code)))))) (ert-deftest bytecomp-tests--unescaped-char-literals () "Check that byte compiling warns about unescaped character diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el index fa2e5dc4db7..33ef2c52288 100644 --- a/test/lisp/emacs-lisp/ert-font-lock-tests.el +++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el @@ -44,13 +44,56 @@ (goto-char (point-min)) ,@body)) +(defun ert-font-lock--wrap-begin-end (re) + (concat "^" re "$")) + +;;; Regexp tests +;;; + +(ert-deftest test-regexp--face-symbol-re () + (let ((re (ert-font-lock--wrap-begin-end + ert-font-lock--face-symbol-re))) + (should (string-match-p re "font-lock-keyword-face")) + (should (string-match-p re "-face")) + (should (string-match-p re "weird-package/-face")) + (should (string-match-p re "-")) + (should (string-match-p re "font-lock.face")) + (should-not (string-match-p re "face suffix-with")) + (should-not (string-match-p re "(")))) + +(ert-deftest test-regexp--face-symbol-list-re () + (let ((re (ert-font-lock--wrap-begin-end + ert-font-lock--face-symbol-list-re))) + (should (string-match-p re "(face1 face2)")) + (should (string-match-p re "(face1)")) + (should (string-match-p re "()")) + (should-not (string-match-p re ")")) + (should-not (string-match-p re "(")))) + +(ert-deftest test-regexp--assertion-line-re () + (let ((re (ert-font-lock--wrap-begin-end + ert-font-lock--assertion-line-re))) + (should (string-match-p re "^ something-face")) + (should (string-match-p re "^ !something-face")) + (should (string-match-p re "^ (face1 face2)")) + (should (string-match-p re "^ !(face1 face2)")) + (should (string-match-p re "^ ()")) + (should (string-match-p re "^ !()")) + (should (string-match-p re "^ nil")) + (should (string-match-p re "^ !nil")) + (should (string-match-p re "<- something-face")) + (should (string-match-p re "<- ^ something-face")) + (should (string-match-p re "^^ ^ something-face")) + (should (string-match-p re "^ ^something-face")) + (should-not (string-match-p re "^ <- ^something-face")))) + ;;; Comment parsing tests ;; (ert-deftest test-line-comment-p--fundamental () (with-temp-buffer-str-mode fundamental-mode - "// comment\n" - (should-not (ert-font-lock--line-comment-p)))) + "// comment\n" + (should-not (ert-font-lock--line-comment-p)))) (ert-deftest test-line-comment-p--emacs-lisp () (with-temp-buffer-str-mode emacs-lisp-mode diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el index 5358bcaeb5c..c59a6b9f8f1 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/vk.el +++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el @@ -78,29 +78,31 @@ (defconst vk-val3 (eval-when-compile (vk-f3 0))) -(defconst vk-f4 '(lambda (x) - (defvar vk-v4) - (let ((vk-v4 31) - (y 32)) - (ignore vk-v4 x y) - (list - (vk-variable-kind vk-a) ; dyn - (vk-variable-kind vk-b) ; dyn - (vk-variable-kind vk-v4) ; dyn - (vk-variable-kind x) ; dyn - (vk-variable-kind y))))) ; dyn - -(defconst vk-f5 '(closure (t) (x) - (defvar vk-v5) - (let ((vk-v5 41) - (y 42)) - (ignore vk-v5 x y) - (list - (vk-variable-kind vk-a) ; dyn - (vk-variable-kind vk-b) ; dyn - (vk-variable-kind vk-v5) ; dyn - (vk-variable-kind x) ; lex - (vk-variable-kind y))))) ; lex +(defconst vk-f4 (eval '(lambda (x) + (defvar vk-v4) + (let ((vk-v4 31) + (y 32)) + (ignore vk-v4 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v4) ; dyn + (vk-variable-kind x) ; dyn + (vk-variable-kind y)))) ; dyn + nil)) + +(defconst vk-f5 (eval '(lambda (x) + (defvar vk-v5) + (let ((vk-v5 41) + (y 42)) + (ignore vk-v5 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v5) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y)))) ; lex + t)) (defun vk-f6 () (eval '(progn diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index 4760f403158..14c205631e0 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -32,7 +32,7 @@ (cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>") -(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>") +(cl-defmethod oclosure-test-gen ((_x interpreted-function)) "#<interpreted-function>") (cl-defmethod oclosure-test-gen ((_x oclosure)) (format "#<oclosure:%s>" (cl-call-next-method))) @@ -63,7 +63,7 @@ (should (cl-typep ocl1 'oclosure-test)) (should (cl-typep ocl1 'oclosure)) (should (member (oclosure-test-gen ocl1) - '("#<oclosure-test:#<oclosure:#<cons>>>" + '("#<oclosure-test:#<oclosure:#<interpreted-function>>>" "#<oclosure-test:#<oclosure:#<bytecode>>>"))) (should (stringp (documentation #'oclosure-test--fst))) )) diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 072209bcbcc..1bb79f72671 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -619,18 +619,19 @@ "[^amz]\\S_")))) (ert-deftest rx-constituents () - (let ((rx-constituents - (append '((beta . gamma) - (gamma . "a*b") - (delta . ((lambda (form) - (regexp-quote (format "<%S>" form))) - 1 nil symbolp)) - (epsilon . delta)) - rx-constituents))) - (should (equal (rx-to-string '(seq (+ beta) nonl gamma) t) - "\\(?:a*b\\)+.\\(?:a*b\\)")) - (should (equal (rx-to-string '(seq (delta a b c) (* (epsilon d e))) t) - "\\(?:<(delta a b c)>\\)\\(?:<(epsilon d e)>\\)*")))) + (with-suppressed-warnings ((obsolete rx-constituents)) + (let ((rx-constituents + (append '((beta . gamma) + (gamma . "a*b") + (delta . ((lambda (form) + (regexp-quote (format "<%S>" form))) + 1 nil symbolp)) + (epsilon . delta)) + rx-constituents))) + (should (equal (rx-to-string '(seq (+ beta) nonl gamma) t) + "\\(?:a*b\\)+.\\(?:a*b\\)")) + (should (equal (rx-to-string '(seq (delta a b c) (* (epsilon d e))) t) + "\\(?:<(delta a b c)>\\)\\(?:<(epsilon d e)>\\)*"))))) (ert-deftest rx-compat () "Test old symbol retained for compatibility (bug#37517)." diff --git a/test/lisp/emacs-lisp/track-changes-tests.el b/test/lisp/emacs-lisp/track-changes-tests.el new file mode 100644 index 00000000000..ed35477cafd --- /dev/null +++ b/test/lisp/emacs-lisp/track-changes-tests.el @@ -0,0 +1,156 @@ +;;; track-changes-tests.el --- tests for emacs-lisp/track-changes.el -*- lexical-binding:t -*- + +;; Copyright (C) 2024 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 'track-changes) +(require 'cl-lib) +(require 'ert) + +(defun track-changes-tests--random-word () + (let ((chars ())) + (dotimes (_ (1+ (random 12))) + (push (+ ?A (random (1+ (- ?z ?A)))) chars)) + (apply #'string chars))) + +(defvar track-changes-tests--random-verbose nil) + +(defun track-changes-tests--message (&rest args) + (when track-changes-tests--random-verbose (apply #'message args))) + +(defvar track-changes-tests--random-seed + (let ((seed (number-to-string (random (expt 2 24))))) + (message "Random seed = %S" seed) + seed)) + +(ert-deftest track-changes-tests--random () + ;; Keep 2 buffers in sync with a third one as we make random + ;; changes to that 3rd one. + ;; We have 3 trackers: a "normal" one which we sync + ;; at random intervals, one which syncs via the "disjoint" signal, + ;; plus a third one which verifies that "nobefore" gets + ;; information consistent with the "normal" tracker. + (with-temp-buffer + (random track-changes-tests--random-seed) + (dotimes (_ 100) + (insert (track-changes-tests--random-word) "\n")) + (let* ((buf1 (generate-new-buffer " *tc1*")) + (buf2 (generate-new-buffer " *tc2*")) + (char-counts (make-vector 2 0)) + (sync-counts (make-vector 2 0)) + (print-escape-newlines t) + (file (make-temp-file "tc")) + (id1 (track-changes-register #'ignore)) + (id3 (track-changes-register #'ignore :nobefore t)) + (sync + (lambda (id buf n) + (track-changes-tests--message "!! SYNC %d !!" n) + (track-changes-fetch + id (lambda (beg end before) + (when (eq n 1) + (track-changes-fetch + id3 (lambda (beg3 end3 before3) + (should (eq beg3 beg)) + (should (eq end3 end)) + (should (eq before3 + (if (symbolp before) + before (length before))))))) + (cl-incf (aref sync-counts (1- n))) + (cl-incf (aref char-counts (1- n)) (- end beg)) + (let ((after (buffer-substring beg end))) + (track-changes-tests--message + "Sync:\n %S\n=> %S\nat %d .. %d" + before after beg end) + (with-current-buffer buf + (if (eq before 'error) + (erase-buffer) + (should (equal before + (buffer-substring + beg (+ beg (length before))))) + (delete-region beg (+ beg (length before)))) + (goto-char beg) + (insert after))) + (should (equal (buffer-string) + (with-current-buffer buf + (buffer-string)))))))) + (id2 (track-changes-register + (lambda (id2 &optional distance) + (when distance + (track-changes-tests--message "Disjoint distance: %d" + distance) + (funcall sync id2 buf2 2))) + :disjoint t))) + (write-region (point-min) (point-max) file) + (insert-into-buffer buf1) + (insert-into-buffer buf2) + (should (equal (buffer-hash) (buffer-hash buf1))) + (should (equal (buffer-hash) (buffer-hash buf2))) + (message "seeding with: %S" track-changes-tests--random-seed) + (dotimes (_ 1000) + (pcase (random 15) + (0 + (track-changes-tests--message "Manual sync1") + (funcall sync id1 buf1 1)) + (1 + (track-changes-tests--message "Manual sync2") + (funcall sync id2 buf2 2)) + ((pred (< _ 5)) + (let* ((beg (+ (point-min) (random (1+ (buffer-size))))) + (end (min (+ beg (1+ (random 100))) (point-max)))) + (track-changes-tests--message "Fill %d .. %d" beg end) + (fill-region-as-paragraph beg end))) + ((pred (< _ 8)) + (let* ((beg (+ (point-min) (random (1+ (buffer-size))))) + (end (min (+ beg (1+ (random 12))) (point-max)))) + (track-changes-tests--message "Delete %S at %d .. %d" + (buffer-substring beg end) beg end) + (delete-region beg end))) + ((and 8 (guard (= (random 50) 0))) + (track-changes-tests--message "Silent insertion") + (let ((inhibit-modification-hooks t)) + (insert "a"))) + ((and 8 (guard (= (random 10) 0))) + (track-changes-tests--message "Revert") + (insert-file-contents file nil nil nil 'replace)) + ((and 8 (guard (= (random 3) 0))) + (let* ((beg (+ (point-min) (random (1+ (buffer-size))))) + (end (min (+ beg (1+ (random 12))) (point-max))) + (after (eq (random 2) 0))) + (track-changes-tests--message "Bogus %S %d .. %d" + (if after 'after 'before) beg end) + (if after + (run-hook-with-args 'after-change-functions + beg end (- end beg)) + (run-hook-with-args 'before-change-functions beg end)))) + (_ + (goto-char (+ (point-min) (random (1+ (buffer-size))))) + (let ((word (track-changes-tests--random-word))) + (track-changes-tests--message "insert %S at %d" word (point)) + (insert word "\n"))))) + (message "SCOREs: default: %d/%d=%d disjoint: %d/%d=%d" + (aref char-counts 0) (aref sync-counts 0) + (/ (aref char-counts 0) (aref sync-counts 0)) + (aref char-counts 1) (aref sync-counts 1) + (/ (aref char-counts 1) (aref sync-counts 1)))))) + + + +;;; track-changes-tests.el ends here diff --git a/test/lisp/erc/erc-button-tests.el b/test/lisp/erc/erc-button-tests.el index 603b3745a27..9d8fb0081c5 100644 --- a/test/lisp/erc/erc-button-tests.el +++ b/test/lisp/erc/erc-button-tests.el @@ -74,9 +74,11 @@ (entry (list (rx "+1") 0 func #'ignore 0)) (erc-button-alist (cons entry erc-button-alist))) - (erc-display-message nil 'notice (current-buffer) "Foo bar baz") - (erc-display-message nil nil (current-buffer) "+1") - (erc-display-message nil 'notice (current-buffer) "Spam") + (erc-tests-common-display-message nil 'notice (current-buffer) + "Foo bar baz") + (erc-tests-common-display-message nil nil (current-buffer) "+1") + (erc-tests-common-display-message nil 'notice (current-buffer) "Spam") + (should (equal (pop erc-button-tests--form) '(53 55 ignore nil ("+1") "\\+1"))) (should-not erc-button-tests--form) diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el index 3c4ad04abd7..f8bfc362085 100644 --- a/test/lisp/erc/erc-fill-tests.el +++ b/test/lisp/erc/erc-fill-tests.el @@ -48,7 +48,7 @@ :command "PRIVMSG" :command-args (list "#chan" msg) :contents msg))) - (erc-display-message parsed nil (current-buffer) msg))) + (erc-tests-common-display-message parsed nil (current-buffer) msg))) (defun erc-fill-tests--wrap-populate (test) (let ((original-window-buffer (window-buffer (selected-window))) @@ -79,7 +79,7 @@ (erc-update-channel-member "#chan" "bob" "bob" t nil nil nil nil nil "fake" "~u" nil nil t) - (erc-display-message + (erc-tests-common-display-message nil 'notice (current-buffer) (concat "This server is in debug mode and is logging all user I/O. " "If you do not wish for everything you send to be readable " @@ -260,29 +260,31 @@ (erc-fill-tests--insert-privmsg "bob" "zero.") (erc-fill-tests--insert-privmsg "bob" "0.5") - (erc-process-ctcp-query - erc-server-process - (make-erc-response - :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION one.\1" - :sender "bob!~u@fake" - :command "PRIVMSG" - :command-args '("#chan" "\1ACTION one.\1") - :contents "\1ACTION one.\1") - "bob" "~u" "fake") + (erc-tests-common-with-date-aware-display-message + (erc-process-ctcp-query + erc-server-process + (make-erc-response + :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION one.\1" + :sender "bob!~u@fake" + :command "PRIVMSG" + :command-args '("#chan" "\1ACTION one.\1") + :contents "\1ACTION one.\1") + "bob" "~u" "fake")) (erc-fill-tests--insert-privmsg "bob" "two.") (erc-fill-tests--insert-privmsg "bob" "2.5") ;; Compat switch to opt out of overhanging speaker. - (let (erc-fill--wrap-action-dedent-p) - (erc-process-ctcp-query - erc-server-process - (make-erc-response - :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION three\1" - :sender "bob!~u@fake" :command "PRIVMSG" - :command-args '("#chan" "\1ACTION three\1") - :contents "\1ACTION three\1") - "bob" "~u" "fake")) + (erc-tests-common-with-date-aware-display-message + (let (erc-fill--wrap-action-dedent-p) + (erc-process-ctcp-query + erc-server-process + (make-erc-response + :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION three\1" + :sender "bob!~u@fake" :command "PRIVMSG" + :command-args '("#chan" "\1ACTION three\1") + :contents "\1ACTION three\1") + "bob" "~u" "fake"))) (erc-fill-tests--insert-privmsg "bob" "four.")) @@ -299,17 +301,9 @@ (ert-deftest erc-fill-wrap--merge-action/indicator-pre () :tags `(:unstable ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) - (let ((erc-fill-wrap-merge-indicator '(pre ?> shadow))) + (let ((erc-fill-wrap-merge-indicator '(?> . shadow))) (erc-fill-wrap-tests--merge-action "merge-wrap-indicator-pre-01"))) -;; One crucial thing this test asserts is that the indicator is -;; omitted when the previous line ends in a stamp. -(ert-deftest erc-fill-wrap--merge-action/indicator-post () - :tags `(:unstable - ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) - (let ((erc-fill-wrap-merge-indicator '(post ?~ shadow))) - (erc-fill-wrap-tests--merge-action "merge-wrap-indicator-post-01"))) - (ert-deftest erc-fill-line-spacing () :tags `(:unstable ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) @@ -320,8 +314,10 @@ (erc-fill-tests--wrap-populate (lambda () (erc-fill-tests--insert-privmsg "bob" "This buffer is for text.") - (erc-display-message nil 'notice (current-buffer) "one two three") - (erc-display-message nil 'notice (current-buffer) "four five six") + (erc-tests-common-display-message nil 'notice + (current-buffer) "one two three") + (erc-tests-common-display-message nil 'notice + (current-buffer) "four five six") (erc-fill-tests--insert-privmsg "bob" "Somebody stop me") (erc-fill-tests--compare "spacing-01-mono"))))) @@ -450,4 +446,34 @@ rear-nonsticky t font-lock-face erc-prompt-face)))))))))) +(ert-deftest erc-fill--wrap-massage-legacy-indicator-type () + (let (calls + erc-fill-wrap-merge-indicator) + (cl-letf (((symbol-function 'erc--warn-once-before-connect) + (lambda (_ &rest args) (push args calls)))) + ;; List of (pre CHAR FACE) becomes (CHAR . FACE). + (let ((erc-fill-wrap-merge-indicator + '(pre #xb7 erc-fill-wrap-merge-indicator-face))) + (erc-fill--wrap-massage-legacy-indicator-type) + (should (equal erc-fill-wrap-merge-indicator + '(#xb7 . erc-fill-wrap-merge-indicator-face))) + (should (string-search "(pre CHAR FACE)" (nth 1 (pop calls))))) + + ;; Cons of (CHAR . STRING) becomes STRING. + (let ((erc-fill-wrap-merge-indicator '(pre . "\u00b7"))) + (erc-fill--wrap-massage-legacy-indicator-type) + (should (equal erc-fill-wrap-merge-indicator "\u00b7")) + (should (string-search "(pre . STRING)" (nth 1 (pop calls))))) + + ;; Anything with a CAR of `post' becomes nil. + (let ((erc-fill-wrap-merge-indicator + '(post #xb6 erc-fill-wrap-merge-indicator-face))) + (erc-fill--wrap-massage-legacy-indicator-type) + (should-not erc-fill-wrap-merge-indicator) + (should (string-search "no longer available" (nth 1 (pop calls))))) + (let ((erc-fill-wrap-merge-indicator '(post . "\u00b7"))) + (erc-fill--wrap-massage-legacy-indicator-type) + (should-not erc-fill-wrap-merge-indicator) + (should (string-search "no longer available" (nth 1 (pop calls)))))))) + ;;; erc-fill-tests.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-association-nick.el b/test/lisp/erc/erc-scenarios-base-association-nick.el index 57e8abda73c..c4601f3771f 100644 --- a/test/lisp/erc/erc-scenarios-base-association-nick.el +++ b/test/lisp/erc/erc-scenarios-base-association-nick.el @@ -28,22 +28,22 @@ ;; You register a new nick in a dedicated query buffer, disconnect, ;; and log back in, but your nick is not granted (maybe you just -;; turned off SASL). In any case, ERC obtains a backtick'd version. +;; turned off SASL). In any case, ERC obtains a backticked version. ;; You open a query buffer for NickServ, and ERC gives you the ;; existing one. And after you identify, all buffers retain their ;; names, although your net ID has changed internally. ;; -;; If ERC would've instead failed (or intentionally refused) to make -;; the association, you would've ended up with a new NickServ buffer -;; named after the new net ID as a suffix (based on the backtick'd -;; nick), for example, NickServ@foonet/tester`. And the original -;; (disconnected) NickServ buffer would've gotten suffixed with *its* -;; net-ID as well, e.g., NickServ@foonet/tester. And after -;; identifying, you would've seen ERC merge the two as well as their -;; server buffers. While this alternate behavior may arguably be a -;; more honest reflection of reality, it's also quite inconvenient. -;; For a clearer example, see the original version of this file -;; introduced by "Add user-oriented test scenarios for ERC". +;; If ERC had instead failed (or intentionally refused) to make the +;; association, you would find yourself with a new NickServ buffer +;; named with a suffix reflecting the new net ID (based on the +;; backticked nick), for example, NickServ@foonet/tester`. And the +;; original (disconnected) NickServ buffer would also receive a suffix +;; with *its* net-ID, e.g., NickServ@foonet/tester. Upon identifying +;; yourself, you'd see ERC merge both buffers along with their server +;; buffers. While this alternate behavior might more accurately +;; reflect reality, it introduces significant inconvenience. For a +;; clearer example, see the original version of this file introduced +;; by "Add user-oriented test scenarios for ERC". (ert-deftest erc-scenarios-base-association-nick-bumped () :tags '(:expensive-test) diff --git a/test/lisp/erc/erc-scenarios-base-renick.el b/test/lisp/erc/erc-scenarios-base-renick.el index e0fcb8b9366..3001fde6da0 100644 --- a/test/lisp/erc/erc-scenarios-base-renick.el +++ b/test/lisp/erc/erc-scenarios-base-renick.el @@ -177,7 +177,7 @@ (ert-info ("Joined by bouncer to #foo, pal persent") (with-current-buffer (erc-d-t-wait-for 1 (get-buffer "#foo")) - (erc-d-t-search-for 1 "On Thursday") + (erc-d-t-search-for 5 "On Thursday") (erc-scenarios-common-say "hi"))) (erc-d-t-wait-for 10 "Query buffer appears with message from pal" @@ -253,7 +253,7 @@ (ert-info ("Joined by bouncer to #chan@barnet, pal persent") (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan@barnet")) (funcall expect 1 "rando") - (funcall expect 2 "come, sir, I am"))) + (funcall expect 5 "come, sir, I am"))) (ert-info ("Query buffer exists for rando@foonet") (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "rando@foonet")) diff --git a/test/lisp/erc/erc-scenarios-ignore.el b/test/lisp/erc/erc-scenarios-ignore.el new file mode 100644 index 00000000000..55be613b51b --- /dev/null +++ b/test/lisp/erc/erc-scenarios-ignore.el @@ -0,0 +1,79 @@ +;;; erc-scenarios-ignore.el --- /IGNORE scenarios ERC -*- lexical-binding: t -*- + +;; Copyright (C) 2024 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: + +;; TODO add test covering the same ignored speaker in two different +;; channels on the same server: they should be ignored in both. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-ignore/basic () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/assoc/multi-net") + (erc-server-flood-penalty 0.1) + (dumb-server-foonet (erc-d-run "localhost" t 'foonet)) + (dumb-server-barnet (erc-d-run "localhost" t 'barnet)) + (erc-autojoin-channels-alist '((foonet "#chan") (barnet "#chan"))) + (port-foonet (process-contact dumb-server-foonet :service)) + (port-barnet (process-contact dumb-server-barnet :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to two networks") + (with-current-buffer (erc :server "127.0.0.1" + :port port-barnet + :nick "tester" + :password "changeme" + :full-name "tester")) + (with-current-buffer (erc :server "127.0.0.1" + :port port-foonet + :nick "tester" + :password "changeme" + :full-name "tester") + (funcall expect 10 "debug mode"))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan@foonet")) + (funcall expect 10 "<bob> tester, welcome!") + (funcall expect 10 "<alice> tester, welcome!") + (erc-scenarios-common-say "/ignore alice 1m") + (erc-scenarios-common-say "/ignore mike 1h") + (funcall expect 10 "ignoring alice for 1m0s") + (funcall expect 10 "<bob> alice: Signior Iachimo") + (erc-scenarios-common-say "/ignore") + (funcall expect 20 '(: "alice 5" (any "0-9") "s")) + (funcall expect 10 '(: "mike 59m5" (any "0-9") "s")) + (funcall expect -0.1 "<alice>") + (funcall expect 10 "<bob> alice: The ground is bloody") + (erc-scenarios-common-say "/unignore alice") + (funcall expect 10 "<alice>")) + + ;; No <mike> messages were ignored on network barnet. + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan@barnet")) + (funcall expect 10 "<mike> tester, welcome!") + (funcall expect 10 "<joe> tester, welcome!") + (funcall expect 10 "<mike> joe: Whipp'd") + (funcall expect 10 "<mike> joe: Double")))) + +;;; erc-scenarios-ignore.el ends here diff --git a/test/lisp/erc/erc-scenarios-match.el b/test/lisp/erc/erc-scenarios-match.el index 22e34a8efe8..8600af800f1 100644 --- a/test/lisp/erc/erc-scenarios-match.el +++ b/test/lisp/erc/erc-scenarios-match.el @@ -71,7 +71,8 @@ ;; (defun erc-scenarios-match--invisible-stamp (hiddenp visiblep) (unless noninteractive - (kill-new "erc-match-toggle-hidden-fools")) + (push "erc-match-toggle-hidden-fools" extended-command-history) + (push "erc-toggle-timestamps" extended-command-history)) (erc-scenarios-common-with-cleanup ((erc-scenarios-common-dialog "join/legacy") diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el index 2afa1ce67a4..4cb5e65b15a 100644 --- a/test/lisp/erc/erc-scenarios-misc.el +++ b/test/lisp/erc/erc-scenarios-misc.el @@ -49,7 +49,7 @@ (ert-info ("#chan@foonet exists") (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan/foonet")) - (erc-d-t-search-for 2 "<bob/foonet>") + (erc-d-t-search-for 10 "<bob/foonet>") (erc-d-t-absent-for 0.1 "<joe") (funcall expect 3 "was created on"))) @@ -58,7 +58,7 @@ (erc-d-t-search-for 2 "<joe/barnet>") (erc-d-t-absent-for 0.1 "<bob") (funcall expect 3 "was created on") - (funcall expect 5 "To get good guard"))) + (funcall expect 10 "To get good guard"))) (ert-info ("Message not held in queue limbo") (with-current-buffer "#chan/foonet" diff --git a/test/lisp/erc/erc-scenarios-stamp.el b/test/lisp/erc/erc-scenarios-stamp.el index 3a10f709548..6f2fbc1b7e9 100644 --- a/test/lisp/erc/erc-scenarios-stamp.el +++ b/test/lisp/erc/erc-scenarios-stamp.el @@ -101,17 +101,19 @@ :port port :full-name "tester" :nick "tester") - (funcall expect 5 "Opening connection") + (funcall expect 5 "*** Welcome") (goto-char (1- (match-beginning 0))) (should (eq 'erc-timestamp (field-at-pos (point)))) - (should (eq 'unknown (erc--get-inserted-msg-prop 'erc--msg))) + (should (eq 'notice (erc--get-inserted-msg-prop 'erc--msg))) ;; Force redraw of date stamp. (setq erc-timestamp-last-inserted-left nil) (funcall expect 5 "This server is in debug mode") (while (and (zerop (forward-line -1)) (not (eq 'erc-timestamp (field-at-pos (point)))))) - (should (erc--get-inserted-msg-prop 'erc--cmd))))))) + (should (erc--get-inserted-msg-prop 'erc--cmd)) + (should-not erc-stamp--date-mode) + (should-not erc-stamp--date-stamps)))))) ;; This user-owned hook member places a marker on the first message in ;; a buffer. Inserting a date stamp in front of it shouldn't move the diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 3e8ddef3731..999d9f100c9 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -50,6 +50,34 @@ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) (should (equal (erc--read-time-period "foo: ") 86400)))) +(ert-deftest erc--format-time-period () + (should (equal (erc--format-time-period 59) "59s")) + (should (equal (erc--format-time-period 59.9) "59s")) + (should (equal (erc--format-time-period 60) "1m0s")) + (should (equal (erc--format-time-period 119) "1m59s")) + (should (equal (erc--format-time-period 119.9) "1m59s")) + (should (equal (erc--format-time-period 120.9) "2m0s")) + (should (equal (erc--format-time-period 3599.9) "59m59s")) + (should (equal (erc--format-time-period 3600) "1h0m0s"))) + +;; This asserts that the first pattern on file matching a supplied +;; `user' parameter will be removed after confirmation. +(ert-deftest erc-cmd-UNIGNORE () + ;; XXX these functions mutate `erc-ignore-list' via `delete'. + (should (local-variable-if-set-p 'erc-ignore-list)) + (erc-tests-common-make-server-buf) + + (setq erc-ignore-list (list ".")) ; match anything + (ert-simulate-keys (list ?\r) + (erc-cmd-IGNORE "abc")) + (should (equal erc-ignore-list (list "abc" "."))) + + (cl-letf (((symbol-function 'y-or-n-p) #'always)) + (erc-cmd-UNIGNORE "abcdef") + (should (equal erc-ignore-list (list "."))) + (erc-cmd-UNIGNORE "foo")) + (should-not erc-ignore-list)) + (ert-deftest erc-with-all-buffers-of-server () (let (proc-exnet proc-onet @@ -1199,6 +1227,35 @@ (erc-tests-common-kill-buffers)) +(ert-deftest erc-query-buffer-p () + ;; Nil in a non-ERC buffer. + (should-not (erc-query-buffer-p)) + (should-not (erc-query-buffer-p (current-buffer))) + (should-not (erc-query-buffer-p (buffer-name))) + + (erc-tests-common-make-server-buf) + ;; Nil in a server buffer. + (should-not (erc-query-buffer-p)) + (should-not (erc-query-buffer-p (current-buffer))) + (should-not (erc-query-buffer-p (buffer-name))) + + ;; Nil in a channel buffer. + (with-current-buffer (erc--open-target "#chan") + (should-not (erc-query-buffer-p)) + (should-not (erc-query-buffer-p (current-buffer))) + (should-not (erc-query-buffer-p (buffer-name)))) + + ;; Non-nil in a query buffer. + (with-current-buffer (erc--open-target "alice") + (should (erc-query-buffer-p)) + (should (erc-query-buffer-p (current-buffer))) + (should (erc-query-buffer-p (buffer-name)))) + + (should (erc-query-buffer-p (get-buffer "alice"))) + (should (erc-query-buffer-p "alice")) + + (erc-tests-common-kill-buffers)) + (ert-deftest erc--valid-local-channel-p () (ert-info ("Local channels not supported") (let ((erc--isupport-params (make-hash-table))) @@ -1899,7 +1956,48 @@ (lambda (arg) (should (equal '(3 . 11) (erc--get-inserted-msg-bounds arg)))))) -(ert-deftest erc--delete-inserted-message () +(ert-deftest erc--insert-before-markers-transplanting-hidden () + (with-current-buffer (get-buffer-create "*erc-test*") + (erc-mode) + (erc-tests-common-prep-for-insertion) + + ;; Create a message that has a foreign invisibility property on + ;; its trailing newline that's not claimed by the next message. + (let ((erc-insert-post-hook + (lambda () + (put-text-property (point-min) (point-max) 'invisible 'b)))) + (erc-display-message nil 'notice (current-buffer) "before")) + (should (eq 'b (get-text-property (1- erc-insert-marker) 'invisible))) + + ;; Insert a message that's hidden with `erc--hide-message'. It + ;; advertises `invisible' value `a', applied on the trailing + ;; newline of the previous message. + (let ((erc-insert-post-hook (lambda () (erc--hide-message 'a)))) + (erc-display-message nil 'notice (current-buffer) "after")) + + (goto-char (point-min)) + (should (search-forward "*** before\n" nil t)) + (should (equal '(a b) (get-text-property (1- (point)) 'invisible))) + + ;; Splice in a new message. + (let ((erc--insert-line-function + #'erc--insert-before-markers-transplanting-hidden) + (erc--insert-marker (copy-marker (point)))) + (goto-char (point-max)) + (erc-display-message nil 'notice (current-buffer) "middle")) + + (goto-char (point-min)) + (should (search-forward "*** before\n" nil t)) + (should (eq 'b (get-text-property (1- (point)) 'invisible))) + (should (looking-at (rx "*** middle\n"))) + (should (eq 'a (get-text-property (pos-eol) 'invisible))) + (forward-line) + (should (looking-at (rx "*** after\n"))) + + (setq buffer-invisibility-spec nil) + (when noninteractive (kill-buffer)))) + +(ert-deftest erc--delete-inserted-message-naively () (erc-mode) (erc--initialize-markers (point) nil) ;; Put unique invisible properties on the line endings. @@ -1917,7 +2015,7 @@ (should (eq 'datestamp (get-text-property (point) 'erc--msg))) (should (eq (point) (field-beginning (1+ (point))))) - (erc--delete-inserted-message (point)) + (erc--delete-inserted-message-naively (point)) ;; Preceding line ending clobbered, replaced by trailing. (should (looking-back (rx "*** one\n"))) @@ -1933,7 +2031,7 @@ (p (point))) (set-marker-insertion-type m t) (goto-char (point-max)) - (erc--delete-inserted-message p) + (erc--delete-inserted-message-naively p) (should (= (marker-position n) p)) (should (= (marker-position m) p)) (goto-char p) @@ -1947,7 +2045,7 @@ (should (looking-at (rx "*** three\n"))) (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) (let ((erc-legacy-invisible-bounds-p t)) - (erc--delete-inserted-message (point)))) + (erc--delete-inserted-message-naively (point)))) (should (looking-at (rx "*** four\n")))) (ert-info ("Deleting most recent message preserves markers") @@ -1957,7 +2055,7 @@ (should (equal "*** four\n" (buffer-substring p erc-insert-marker))) (set-marker-insertion-type m t) (goto-char (point-max)) - (erc--delete-inserted-message p) + (erc--delete-inserted-message-naively p) (should (= (marker-position m) p)) (should (= (marker-position n) p)) (goto-char p) @@ -2013,6 +2111,13 @@ (let ((v '(42 y))) (should-not (erc--check-msg-prop 'b v))))) +(ert-deftest erc--memq-msg-prop () + (let ((erc--msg-props (map-into '((a . 1) (b x y)) 'hash-table))) + (should-not (erc--memq-msg-prop 'a 1)) + (should-not (erc--memq-msg-prop 'b 'z)) + (should (erc--memq-msg-prop 'b 'x)) + (should (erc--memq-msg-prop 'b 'y)))) + (ert-deftest erc--merge-prop () (with-current-buffer (get-buffer-create "*erc-test*") ;; Baseline. diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld index 060f4178723..5e7ac8afb41 100644 --- a/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld +++ b/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld @@ -1,5 +1,5 @@ ;; -*- mode: lisp-data; -*- -((pass 3 "PASS :barnet:changeme")) +((pass 10 "PASS :barnet:changeme")) ((nick 1 "NICK tester")) ((user 1 "USER user 0 * :tester") (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester") diff --git a/test/lisp/erc/resources/base/auth-source/foonet.eld b/test/lisp/erc/resources/base/auth-source/foonet.eld index 1fe772c7e23..31ddccbdaee 100644 --- a/test/lisp/erc/resources/base/auth-source/foonet.eld +++ b/test/lisp/erc/resources/base/auth-source/foonet.eld @@ -1,5 +1,5 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :changeme")) +((pass 10 "PASS :changeme")) ((nick 1 "NICK tester")) ((user 1 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") diff --git a/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld b/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld index d106a45cf66..17f3cfd72b1 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld @@ -34,7 +34,7 @@ (0 ":irc.barnet.org NOTICE tester :[09:05:35] This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.") (0 ":irc.barnet.org 305 tester :You are no longer marked as being away")) -((mode 3 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1620205534") (0.1 ":mike!~u@wvys46tx8tpmk.irc PRIVMSG #chan :joe: That will be given to the loudest noise we make.") diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index 78f87399afb..dd0d5f8cb87 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -367,8 +367,6 @@ (should (equal (funcall it) "foo3foo"))) (ert-info ("Exits clean") - (when (listp (alist-get 'f (erc-d-dialog-vars dialog))) ; may be compiled - (should (eq 'closure (car (alist-get 'f (erc-d-dialog-vars dialog)))))) (should-not (funcall it)) (should (equal (erc-d-dialog-vars dialog) `((:a . 1) @@ -646,7 +644,7 @@ nonzero for this to work." (ert-deftest erc-d-run-basic () :tags '(:expensive-test) (erc-d-tests-with-server (_ _) basic - (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) (erc-d-t-search-for 2 "hey")) (when noninteractive (kill-buffer "#chan")))) diff --git a/test/lisp/erc/resources/erc-scenarios-common.el b/test/lisp/erc/resources/erc-scenarios-common.el index 9ad5ce49429..c7d5c9d6677 100644 --- a/test/lisp/erc/resources/erc-scenarios-common.el +++ b/test/lisp/erc/resources/erc-scenarios-common.el @@ -194,6 +194,7 @@ Dialog resource directories are located by expanding the variable (ert-info ("Running extra teardown") (funcall erc-scenarios-common-extra-teardown))) + (erc-buffer-do #'erc-scenarios-common--assert-date-stamps) (when (and (boundp 'erc-autojoin-mode) (not (eq erc-autojoin-mode ,orig-autojoin-mode))) (erc-autojoin-mode (if ,orig-autojoin-mode +1 -1))) @@ -325,6 +326,12 @@ See Info node `(emacs) Term Mode' for the various commands." erc-scenarios-common-interactive-debug-term-p)) (erc-scenarios-common-with-cleanup ,@body))) +(defun erc-scenarios-common--assert-date-stamps () + "Ensure all date stamps are accounted for." + (dolist (stamp erc-stamp--date-stamps) + (should (eq 'datestamp (get-text-property (erc-stamp--date-marker stamp) + 'erc--msg))))) + (defun erc-scenarios-common-assert-initial-buf-name (id port) ;; Assert no limbo period when explicit ID given (should (string= (if id diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el index 99f15b89b03..2ec32db77cd 100644 --- a/test/lisp/erc/resources/erc-tests-common.el +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -39,7 +39,7 @@ ;;; Code: (require 'ert-x) (require 'erc) - +(eval-when-compile (require 'erc-stamp)) (defmacro erc-tests-common-equal-with-props (a b) "Compare strings A and B for equality including text props. @@ -196,6 +196,25 @@ For simplicity, assume string evaluates to itself." (erc-readonly-mode +1) (funcall assert-fn test-fn))) +(defun erc-tests--common-display-message (orig &rest args) + (require 'erc-stamp) + (defvar erc-stamp--deferred-date-stamp) + (let (erc-stamp--deferred-date-stamp) + (prog1 (apply orig args) + (when-let ((inst erc-stamp--deferred-date-stamp) + (fn (erc-stamp--date-fn inst))) + (funcall fn))))) + +(defun erc-tests-common-display-message (&rest args) + (apply #'erc-tests--common-display-message #'erc-display-message args)) + +(defmacro erc-tests-common-with-date-aware-display-message (&rest body) + `(progn + (advice-add 'erc-display-message + :around #'erc-tests--common-display-message) + (unwind-protect (progn ,@body) + (advice-remove 'erc-display-message + #'erc-tests--common-display-message)))) ;;;; Buffer snapshots @@ -223,12 +242,19 @@ string." (print-escape-nonascii t) (got (erc--remove-text-properties (buffer-substring (point-min) erc-insert-marker))) - (repr (funcall (or trans-fn #'identity) (prin1-to-string got)))) + (repr (funcall (or trans-fn #'identity) (prin1-to-string got))) + (xstr (read (with-temp-buffer + (insert-file-contents-literally expect-file) + (buffer-string))))) (with-current-buffer (generate-new-buffer name) (with-silent-modifications (insert (setq got (read repr)))) (when buf-init-fn (funcall buf-init-fn)) (erc-mode)) + (unless noninteractive + (with-current-buffer (generate-new-buffer (format "%s-xpt" name)) + (insert xstr) + (erc-mode))) ;; LHS is a string, RHS is a symbol. (if (string= erc-tests-common-snapshot-save-p (ert-test-name (ert-running-test))) @@ -242,9 +268,7 @@ string." ;; recursive (signals `max-lisp-eval-depth' exceeded). (named-let assert-equal ((latest (read repr)) - (expect (read (with-temp-buffer - (insert-file-contents-literally expect-file) - (buffer-string))))) + (expect xstr)) (pcase latest ((or "" 'nil) t) ((pred stringp) diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld index 6ff7af218c0..166ed59e292 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #5#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #5# display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 (8)))) 477 482 (wrap-prefix #1# line-prefix #7#) 482 488 (wrap-prefix #1# line-prefix #7#) 489 490 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #8=(space :width (- 27 0)) display #9="") 490 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 497 (wrap-prefix #1# line-prefix #8# display #9#) 497 501 (wrap-prefix #1# line-prefix #8#) 502 503 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #9#) 516 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 521 (wrap-prefix #1# line-prefix #11# display #9#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 (8)))) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 0)) display #9#) 542 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 549 (wrap-prefix #1# line-prefix #13# display #9#) 549 553 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #5#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #5# display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #8=(space :width (- 27 (8)))) 477 482 (wrap-prefix #1# line-prefix #8#) 482 488 (wrap-prefix #1# line-prefix #8#) 489 490 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 0)) erc-fill--wrap-merge #7="" display #7#) 490 495 (wrap-prefix #1# line-prefix #9# erc-fill--wrap-merge #7# display #7#) 495 497 (wrap-prefix #1# line-prefix #9# erc-fill--wrap-merge #7# display #7#) 497 501 (wrap-prefix #1# line-prefix #9#) 502 503 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) erc-fill--wrap-merge #7# display #7#) 516 519 (wrap-prefix #1# line-prefix #11# erc-fill--wrap-merge #7# display #7#) 519 521 (wrap-prefix #1# line-prefix #11# erc-fill--wrap-merge #7# display #7#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 (8)))) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 0)) erc-fill--wrap-merge #7# display #7#) 542 547 (wrap-prefix #1# line-prefix #13# erc-fill--wrap-merge #7# display #7#) 547 549 (wrap-prefix #1# line-prefix #13# erc-fill--wrap-merge #7# display #7#) 549 553 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld index 7d9822c80bc..8b502373807 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18))) field erc-timestamp) 21 22 (wrap-prefix #1# line-prefix #2=(space :width (- 29 (4))) erc--msg notice erc--ts 0) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (wrap-prefix #1# line-prefix #2# field erc-timestamp) 184 191 (wrap-prefix #1# line-prefix #2# field erc-timestamp display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (wrap-prefix #1# line-prefix #3=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix (space :width (- 29 (8)))) 350 351 (wrap-prefix #1# line-prefix #4=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (wrap-prefix #1# line-prefix (space :width (- 29 (18))) field erc-timestamp) 456 457 (wrap-prefix #1# line-prefix #5=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (wrap-prefix #1# line-prefix #5# field erc-timestamp) 468 475 (wrap-prefix #1# line-prefix #5# field erc-timestamp display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (wrap-prefix #1# line-prefix #7=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG) 477 482 (wrap-prefix #1# line-prefix #7#) 482 488 (wrap-prefix #1# line-prefix #7#) 489 490 (wrap-prefix #1# line-prefix #8=(space :width (- 29 0)) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG display #9="") 490 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 497 (wrap-prefix #1# line-prefix #8# display #9#) 497 501 (wrap-prefix #1# line-prefix #8#) 502 503 (wrap-prefix #1# line-prefix #10=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (wrap-prefix #1# line-prefix #11=(space :width (- 29 0)) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG display #9#) 516 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 521 (wrap-prefix #1# line-prefix #11# display #9#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (wrap-prefix #1# line-prefix #12=(space :width (- 29 (8))) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (wrap-prefix #1# line-prefix #13=(space :width (- 29 0)) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG display #9#) 542 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 549 (wrap-prefix #1# line-prefix #13# display #9#) 549 553 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18))) field erc-timestamp) 21 22 (wrap-prefix #1# line-prefix #2=(space :width (- 29 (4))) erc--msg notice erc--ts 0) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (wrap-prefix #1# line-prefix #2# field erc-timestamp) 184 191 (wrap-prefix #1# line-prefix #2# field erc-timestamp display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (wrap-prefix #1# line-prefix #3=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix (space :width (- 29 (8)))) 350 351 (wrap-prefix #1# line-prefix #4=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (wrap-prefix #1# line-prefix (space :width (- 29 (18))) field erc-timestamp) 456 457 (wrap-prefix #1# line-prefix #5=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (wrap-prefix #1# line-prefix #5# field erc-timestamp) 468 475 (wrap-prefix #1# line-prefix #5# field erc-timestamp display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (wrap-prefix #1# line-prefix #8=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG) 477 482 (wrap-prefix #1# line-prefix #8#) 482 488 (wrap-prefix #1# line-prefix #8#) 489 490 (wrap-prefix #1# line-prefix #9=(space :width (- 29 0)) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG erc-fill--wrap-merge #7="" display #7#) 490 495 (wrap-prefix #1# line-prefix #9# erc-fill--wrap-merge #7# display #7#) 495 497 (wrap-prefix #1# line-prefix #9# erc-fill--wrap-merge #7# display #7#) 497 501 (wrap-prefix #1# line-prefix #9#) 502 503 (wrap-prefix #1# line-prefix #10=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (wrap-prefix #1# line-prefix #11=(space :width (- 29 0)) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc-fill--wrap-merge #7# display #7#) 516 519 (wrap-prefix #1# line-prefix #11# erc-fill--wrap-merge #7# display #7#) 519 521 (wrap-prefix #1# line-prefix #11# erc-fill--wrap-merge #7# display #7#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (wrap-prefix #1# line-prefix #12=(space :width (- 29 (8))) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (wrap-prefix #1# line-prefix #13=(space :width (- 29 0)) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG erc-fill--wrap-merge #7# display #7#) 542 547 (wrap-prefix #1# line-prefix #13# erc-fill--wrap-merge #7# display #7#) 547 549 (wrap-prefix #1# line-prefix #13# erc-fill--wrap-merge #7# display #7#) 549 553 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld index 2d0e5a5965f..9744e659813 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 509 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) erc-fill--wrap-merge #8="" display #8#) 477 480 (wrap-prefix #1# line-prefix #7# erc-fill--wrap-merge #8# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# erc-fill--wrap-merge #8# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) erc-fill--wrap-merge #8# display #8#) 509 512 (wrap-prefix #1# line-prefix #11# erc-fill--wrap-merge #8# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# erc-fill--wrap-merge #8# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld deleted file mode 100644 index e019e60bb26..00000000000 --- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld +++ /dev/null @@ -1 +0,0 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 507 508 (display #("~\n" 0 2 (font-lock-face shadow))) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 509 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld index 615de982b1e..36729b890be 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 #10=(2))) display #8=#("> " 0 1 (font-lock-face shadow))) 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #11#) 501 507 (wrap-prefix #1# line-prefix #11#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 #10#)) display #8#) 509 512 (wrap-prefix #1# line-prefix #12# display #8#) 512 514 (wrap-prefix #1# line-prefix #12# display #8#) 514 517 (wrap-prefix #1# line-prefix #12#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #13=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #13#) 520 523 (wrap-prefix #1# line-prefix #13#) 523 529 (wrap-prefix #1# line-prefix #13#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #14=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #14#) 534 541 (wrap-prefix #1# line-prefix #14#))
\ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 #10=(2))) erc-fill--wrap-merge t display #8=#("> " 0 1 (font-lock-face shadow))) 477 480 (wrap-prefix #1# line-prefix #7# erc-fill--wrap-merge t display #8#) 480 482 (wrap-prefix #1# line-prefix #7# erc-fill--wrap-merge t display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #11#) 501 507 (wrap-prefix #1# line-prefix #11#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 #10#)) erc-fill--wrap-merge t display #8#) 509 512 (wrap-prefix #1# line-prefix #12# erc-fill--wrap-merge t display #8#) 512 514 (wrap-prefix #1# line-prefix #12# erc-fill--wrap-merge t display #8#) 514 517 (wrap-prefix #1# line-prefix #12#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #13=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #13#) 520 523 (wrap-prefix #1# line-prefix #13#) 523 529 (wrap-prefix #1# line-prefix #13#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #14=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #14#) 534 541 (wrap-prefix #1# line-prefix #14#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld index ae364accdea..5405ca2a7dc 100644 --- a/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld +++ b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n<bob> This buffer is for text.\n*** one two three\n*** four five six\n<bob> Somebody stop me\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (line-spacing 0.5) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 349 350 (line-spacing 0.5) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 436 437 (line-spacing 0.5) 437 438 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 0)) display #6="") 438 441 (wrap-prefix #1# line-prefix #5# display #6#) 441 443 (wrap-prefix #1# line-prefix #5# display #6#) 443 467 (wrap-prefix #1# line-prefix #5#) 467 468 (line-spacing 0.5) 468 469 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #7=(space :width (- 27 (4)))) 469 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #8=(space :width (- 27 (4)))) 487 503 (wrap-prefix #1# line-prefix #8#) 503 504 (line-spacing 0.5) 504 505 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 505 508 (wrap-prefix #1# line-prefix #9#) 508 526 (wrap-prefix #1# line-prefix #9#))
\ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n<bob> This buffer is for text.\n*** one two three\n*** four five six\n<bob> Somebody stop me\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (line-spacing 0.5) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 349 350 (line-spacing 0.5) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 436 437 (line-spacing 0.5) 437 438 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 0)) erc-fill--wrap-merge #6="" display #6#) 438 441 (wrap-prefix #1# line-prefix #5# erc-fill--wrap-merge #6# display #6#) 441 443 (wrap-prefix #1# line-prefix #5# erc-fill--wrap-merge #6# display #6#) 443 467 (wrap-prefix #1# line-prefix #5#) 467 468 (line-spacing 0.5) 468 469 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #7=(space :width (- 27 (4)))) 469 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #8=(space :width (- 27 (4)))) 487 503 (wrap-prefix #1# line-prefix #8#) 503 504 (line-spacing 0.5) 504 505 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 505 508 (wrap-prefix #1# line-prefix #9#) 508 526 (wrap-prefix #1# line-prefix #9#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/join/auth-source/foonet.eld b/test/lisp/erc/resources/join/auth-source/foonet.eld index 32b9e3fa0b6..60dff350654 100644 --- a/test/lisp/erc/resources/join/auth-source/foonet.eld +++ b/test/lisp/erc/resources/join/auth-source/foonet.eld @@ -26,7 +26,7 @@ ((join 6.47 "JOIN #spam secret") (0.03 ":dummy!~u@w9rfqveugz722.irc JOIN #spam")) -((mode 1 "MODE #spam") +((mode-spam 10 "MODE #spam") (0.01 ":irc.foonet.org 353 dummy = #spam :~tester dummy") (0.00 ":irc.foonet.org 366 dummy #spam :End of NAMES list") (0.01 ":irc.foonet.org 324 dummy #spam +knt secret") diff --git a/test/lisp/erc/resources/sasl/external.eld b/test/lisp/erc/resources/sasl/external.eld index 2cd237ec4d4..c3e51a8cd6f 100644 --- a/test/lisp/erc/resources/sasl/external.eld +++ b/test/lisp/erc/resources/sasl/external.eld @@ -28,6 +28,6 @@ (0.21 ":irc.example.org 266 tester 1 1 :Current global users 1, max 1") (0.0 ":irc.example.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0.0 ":irc.example.org 221 tester +Zi") (0.0 ":irc.example.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) diff --git a/test/lisp/erc/resources/sasl/plain.eld b/test/lisp/erc/resources/sasl/plain.eld index 1341cd78e5e..aa5f3e80feb 100644 --- a/test/lisp/erc/resources/sasl/plain.eld +++ b/test/lisp/erc/resources/sasl/plain.eld @@ -30,7 +30,7 @@ (0.21 ":irc.example.org 266 tester 1 1 :Current global users 1, max 1") (0.0 ":irc.example.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0.0 ":irc.example.org 221 tester +Zi") (0.0 ":irc.example.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) diff --git a/test/lisp/eshell/em-glob-tests.el b/test/lisp/eshell/em-glob-tests.el index fc460a59eed..d7d8f59eda0 100644 --- a/test/lisp/eshell/em-glob-tests.el +++ b/test/lisp/eshell/em-glob-tests.el @@ -23,6 +23,7 @@ ;;; Code: +(require 'tramp) (require 'ert) (require 'em-glob) @@ -138,9 +139,18 @@ value of `eshell-glob-splice-results'." (ert-deftest em-glob-test/convert/remote-start-directory () "Test converting a glob starting in a remote directory." - (should (equal (eshell-glob-convert "/ssh:nowhere.invalid:some/where/*.el") - '("/ssh:nowhere.invalid:/some/where/" - (("\\`.*\\.el\\'" . "\\`\\.")) nil)))) + (skip-unless (eshell-tests-remote-accessible-p)) + (let* ((default-directory ert-remote-temporary-file-directory) + (remote (file-remote-p default-directory))) + (should (equal (eshell-glob-convert (format "%s/some/where/*.el" remote)) + `(,(format "%s/some/where/" remote) + (("\\`.*\\.el\\'" . "\\`\\.")) nil))))) + +(ert-deftest em-glob-test/convert/quoted-start-directory () + "Test converting a glob starting in a quoted directory name." + (should (equal (eshell-glob-convert + (concat (eshell-escape-arg "some where/") "*.el")) + '("./some where/" (("\\`.*\\.el\\'" . "\\`\\.")) nil)))) ;; Glob matching @@ -288,4 +298,13 @@ value of `eshell-glob-splice-results'." (let ((eshell-error-if-no-glob t)) (should-error (eshell-extended-glob "*.txt"))))) +(ert-deftest em-glob-test/remote-user-directory () + "Test that remote directories using \"~\" pass through unchanged." + (skip-unless (eshell-tests-remote-accessible-p)) + (let* ((default-directory ert-remote-temporary-file-directory) + (remote (file-remote-p default-directory)) + (eshell-error-if-no-glob t)) + (should (equal (eshell-extended-glob (format "%s~/file.txt" remote)) + (format "%s~/file.txt" remote))))) + ;; em-glob-tests.el ends here diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index d4c1ef3ba67..ad54addf06b 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1196,18 +1196,21 @@ unquoted file names." "emacs" (current-buffer) (concat invocation-directory invocation-name) "--version"))) - (accept-process-output proc) - (goto-char (point-min)) - (should (search-forward emacs-version nil t)) - ;; Don't stop the test run with a query, as the subprocess - ;; may or may not be dead by the time we reach here. - (set-process-query-on-exit-flag proc nil) - ;; On MS-Windows, wait for the process to die, since the OS - ;; will not let us delete a directory that is the cwd of a - ;; running process. - (when (eq system-type 'windows-nt) - (while (process-live-p proc) - (sleep-for 0.1))))))) + (unwind-protect + (progn + (accept-process-output proc) + (goto-char (point-min)) + (should (search-forward emacs-version nil t)) + ;; Don't stop the test run with a query, as the subprocess + ;; may or may not be dead by the time we reach here. + (set-process-query-on-exit-flag proc nil) + ;; On MS-Windows, wait for the process to die, since the OS + ;; will not let us delete a directory that is the cwd of a + ;; running process. + (when (eq system-type 'windows-nt) + (while (process-live-p proc) + (sleep-for 0.1)))) + (delete-process proc)))))) (files-tests--with-temp-non-special-and-file-name-handler (tmpdir nospecial-dir t) (with-temp-buffer diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 1beeb77640c..82350a4bc71 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -63,14 +63,14 @@ Return first line of the output of (describe-function-1 FUNC)." (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defun () - (let ((regexp (if (featurep 'native-compile) - "a subr-native-elisp in .+subr\\.el" - "a compiled-function in .+subr\\.el")) + (let ((regexp "a \\([^ ]+\\) in .+subr\\.el") (result (help-fns-tests--describe-function 'last))) - (should (string-match regexp result)))) + (should (string-match regexp result)) + (should (member (match-string 1 result) + '("subr-native-elisp" "byte-code-function"))))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a compiled-function in .+subr\\.el") + (let ((regexp "a byte-code-function in .+subr\\.el") (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index 6a5f03e38a0..020781eff50 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -158,7 +158,7 @@ (ert-deftest image-create-image-with-map () "Test that `create-image' correctly adds :map and/or :original-map." (skip-unless (display-images-p)) - (let ((data "foo") + (let ((data "<svg width=\"30\" height=\"30\" version=\"1.1\" xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"></svg>") (map '(((circle (1 . 1) . 1) a))) (original-map '(((circle (2 . 2) . 2) a))) (original-map-other '(((circle (3 . 3) . 3) a)))) @@ -282,7 +282,7 @@ corresponding coordinate in B. When nil, TOLERANCE defaults to 5." '(((circle (12 . 4) . 2) "circle") ((rect (7 . 3) 9 . 8) "rect") ((poly . [4 6 2 7 1 2]) "poly")))) - (should (equal (image--flip-map (copy-tree map t) t `(,width . ,height)) + (should (equal (image--flip-map (copy-tree map t) `(,width . ,height)) '(((circle (6 . 3) . 2) "circle") ((rect (2 . 6) 7 . 8) "rect") ((poly . [4 11 3 13 8 14]) "poly")))) @@ -291,7 +291,7 @@ corresponding coordinate in B. When nil, TOLERANCE defaults to 5." ;; Scale size because the map has been scaled. (image--rotate-map copy 90 `(,(* 2 width) . ,(* 2 height))) ;; Swap width and height because the map has been flipped. - (image--flip-map copy t `(,(* 2 height) . ,(* 2 width))) + (image--flip-map copy `(,(* 2 height) . ,(* 2 width))) (should (equal copy '(((circle (6 . 8) . 4) "circle") ((rect (12 . 6) 16 . 16) "rect") diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el index edab6845775..b92c45a1d27 100644 --- a/test/lisp/image/gravatar-tests.el +++ b/test/lisp/image/gravatar-tests.el @@ -50,7 +50,7 @@ (should (equal (gravatar--query-string) "r=g&d=404"))) (let ((gravatar-default-image "https://foo/bar.png")) (should (equal (gravatar--query-string) - "r=g&d=https%3A%2F%2Ffoo%2Fbar.png"))))) + "r=g&d=https://foo/bar.png"))))) (ert-deftest gravatar-force-default () "Test query strings for `gravatar-force-default'." diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el index cfbea7378e2..c2afe6e3738 100644 --- a/test/lisp/jsonrpc-tests.el +++ b/test/lisp/jsonrpc-tests.el @@ -108,11 +108,13 @@ (ert-deftest returns-3 () "A basic test for adding two numbers in our test RPC." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (should (= 3 (jsonrpc-request conn '+ [1 2]))))) (ert-deftest errors-with--32601 () "Errors with -32601" + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (condition-case err (progn @@ -123,6 +125,7 @@ (ert-deftest signals-an--32603-JSONRPC-error () "Signals an -32603 JSONRPC error." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (condition-case err (let ((jsonrpc-inhibit-debug-on-error t)) @@ -133,6 +136,7 @@ (ert-deftest times-out () "Request for 3-sec sit-for with 1-sec timeout times out." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (should-error (jsonrpc-request conn 'sit-for [3] :timeout 1)))) @@ -140,11 +144,13 @@ (ert-deftest doesnt-time-out () :tags '(:expensive-test) "Request for 1-sec sit-for with 2-sec timeout succeeds." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (jsonrpc-request conn 'sit-for [1] :timeout 2))) (ert-deftest stretching-it-but-works () "Vector of numbers or vector of vector of numbers are serialized." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be ;; serialized. @@ -161,6 +167,7 @@ (ert-deftest deferred-action-toolate () :tags '(:expensive-test) "Deferred request fails because no one clears the flag." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (should-error (jsonrpc-request conn '+ [1 2] @@ -173,6 +180,7 @@ (ert-deftest deferred-action-intime () :tags '(:expensive-test) "Deferred request barely makes it after event clears a flag." + (skip-when (eq system-type 'windows-nt)) ;; Send an async request, which returns immediately. However the ;; success fun which sets the flag only runs after some time. (jsonrpc--with-emacsrpc-fixture (conn) @@ -191,6 +199,7 @@ (ert-deftest deferred-action-complex-tests () :tags '(:expensive-test) "Test a more complex situation with deferred requests." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (let (n-deferred-1 n-deferred-2 diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index 77046871ea7..a9ae025ad81 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -29,6 +29,46 @@ (require 'ls-lisp) (require 'dired) +(defvar dired-find-subdir) +(ert-deftest ls-lisp-test-bug70271 () + "Test for https://debbugs.gnu.org/70271 ." + (ert-with-temp-file + fpath + :suffix "bug70271" + (let* ((dir (file-name-directory fpath)) + (attributes (file-attributes fpath)) + (dired-find-subdir t) + ls-lisp-use-insert-directory-program buf ts str) + (unwind-protect + (progn + (setq ts (file-attribute-access-time attributes)) + (with-current-buffer + (dired-internal-noselect dir "-la --time=ctime") + (setq buf (current-buffer) + str (format-time-string "%H:%M" ts)) + (goto-char (point-min)) + (should (search-forward-regexp str nil t)) + (kill-buffer)) + (setq ts (- (float-time) 60)) + (set-file-times fpath ts) + (with-current-buffer + (dired-internal-noselect dir "-la --sort=time") + (setq buf (current-buffer) + str (format-time-string "%H:%M" ts)) + (goto-char (point-min)) + (should (search-forward-regexp str nil t)) + (kill-buffer)) + (setq ts (- (float-time) 120)) + (set-file-times fpath ts) + (with-current-buffer + (dired-internal-noselect dir "-la --time=atime") + (setq buf (current-buffer) + str (format-time-string "%H:%M" ts)) + (goto-char (point-min)) + (should (search-forward-regexp str nil t)) + (kill-buffer))) + (when (buffer-live-p buf) (kill-buffer buf)))))) + (ert-deftest ls-lisp-test-bug27762 () "Test for https://debbugs.gnu.org/27762 ." (let* ((dir source-directory) diff --git a/test/lisp/mwheel-tests.el b/test/lisp/mwheel-tests.el index 2b0f0ff384a..f60b9ecd3b0 100644 --- a/test/lisp/mwheel-tests.el +++ b/test/lisp/mwheel-tests.el @@ -23,10 +23,12 @@ (require 'mwheel) (ert-deftest mwheel-test-enable/disable () - (mouse-wheel-mode 1) - (should (eq (lookup-key (current-global-map) `[,mouse-wheel-up-event]) 'mwheel-scroll)) - (mouse-wheel-mode -1) - (should (eq (lookup-key (current-global-map) `[,mouse-wheel-up-event]) nil))) + (with-suppressed-warnings ((obsolete mouse-wheel-up-event)) + (mouse-wheel-mode 1) + (should (eq (lookup-key (current-global-map) `[,mouse-wheel-up-event]) + 'mwheel-scroll)) + (mouse-wheel-mode -1) + (should-not (lookup-key (current-global-map) `[,mouse-wheel-up-event])))) (ert-deftest mwheel-test--create-scroll-keys () (should (equal (mouse-wheel--create-scroll-keys 10 'mouse-4) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index fec252e12dd..413901b0205 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -68,22 +68,35 @@ "Check type conversion functions." (skip-unless dbus--test-enabled-session-bus) - (let ((ustr "0123abc_xyz\x01\xff") - (mstr "Grüß Göttin")) + (let ((ustr (string-to-unibyte "0123abc_xyz\x01\xff")) + (mstr (string-to-multibyte "Grüß Göttin")) + (kstr (encode-coding-string "парола" 'koi8))) (should (string-equal (dbus-byte-array-to-string (dbus-string-to-byte-array "")) "")) (should (string-equal - (dbus-byte-array-to-string (dbus-string-to-byte-array ustr)) ustr)) + (dbus-byte-array-to-string (dbus-string-to-byte-array nil)) "")) (should (string-equal - (dbus-byte-array-to-string (dbus-string-to-byte-array mstr) 'multibyte) - mstr)) - ;; Should not work for multibyte strings. - (should-not + ;; The conversion could return a multibyte string, so we make it unibyte. + (string-to-unibyte + (dbus-byte-array-to-string (dbus-string-to-byte-array ustr))) + ustr)) + (should + (string-equal + ;; The conversion could return a multibyte string, so we make it unibyte. + (string-to-unibyte (dbus-byte-array-to-string (mapcar 'identity ustr))) + ustr)) + (should (string-equal (dbus-byte-array-to-string (dbus-string-to-byte-array mstr)) mstr)) + (should + (string-equal + ;; The conversion could return a multibyte string, so we make it unibyte. + (string-to-unibyte + (dbus-byte-array-to-string (dbus-string-to-byte-array kstr))) + kstr)) (should (string-equal @@ -565,10 +578,10 @@ This includes initialization and closing the bus." ((null args) :ignore) ;; One argument. - ((= 1 (length args)) + ((length= args 1) (car args)) ;; Two arguments. - ((= 2 (length args)) + ((length= args 2) `(:error ,dbus-error-invalid-args ,(format-message "Wrong arguments %s" args))) ;; More than two arguments. @@ -1952,7 +1965,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." (let ((result (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path))) (should - (= 3 (length result))) + (length= result 3)) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) @@ -1970,7 +1983,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." :session dbus--test-service (concat dbus--test-path "/obj0")))) (should - (= 2 (length result))) + (length= result 2)) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) @@ -1989,7 +2002,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." :session dbus--test-service (concat dbus--test-path "/obj0/obj2")))) (should - (= 1 (length result))) + (length= result 1)) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) diff --git a/test/lisp/net/eww-tests.el b/test/lisp/net/eww-tests.el index b83435e0bd9..4ba51da408f 100644 --- a/test/lisp/net/eww-tests.el +++ b/test/lisp/net/eww-tests.el @@ -50,6 +50,7 @@ temporary EWW buffer for our tests." (ert-deftest eww-test/display/html () "Test displaying a simple HTML page." + (skip-unless (libxml-available-p)) (eww-test--with-mock-retrieve (let ((eww-test--response-function (lambda (url) @@ -196,6 +197,7 @@ This sets `eww-before-browse-history-function' to (ert-deftest eww-test/readable/toggle-display () "Test toggling the display of the \"readable\" parts of a web page." + (skip-unless (libxml-available-p)) (eww-test--with-mock-retrieve (let* ((shr-width most-positive-fixnum) (shr-use-fonts nil) @@ -233,7 +235,8 @@ This sets `eww-before-browse-history-function' to (ert-deftest eww-test/readable/default-readable () "Test that EWW displays readable parts of pages by default when applicable." - (eww-test--with-mock-retrieve + (skip-unless (libxml-available-p)) + (eww-test--with-mock-retrieve (let* ((eww-test--response-function (lambda (_url) (concat "Content-Type: text/html\n\n" diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el index 9feba514413..b7dd0b8f7ef 100644 --- a/test/lisp/net/secrets-tests.el +++ b/test/lisp/net/secrets-tests.el @@ -173,6 +173,10 @@ (should (secrets-create-item "session" "foo" "geheim")) (should (equal (secrets-list-items "session") '("foo" "foo"))) + ;; Create another item with a non-latin password. (Bug#70301) + (should (secrets-create-item "session" "parola" "парола")) + (should (string-equal (secrets-get-secret "session" "parola") "парола")) + ;; Create an item with attributes. (should (setq item-path diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index cdd2a1efdb2..f7c83f3b8eb 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2103,14 +2103,18 @@ is greater than 10. (string-equal (file-remote-p (format "/-:%s@:" u) 'method) "ftp")))) ;; Default values in tramp-sh.el and tramp-sudoedit.el. (when (assoc "su" tramp-methods) - (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) + (dolist + (h `("127.0.0.1" "[::1]" "localhost" "localhost4" "localhost6" + "ip6-localhost" "ip6-loopback" ,(system-name))) (should - (string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su"))) - (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit")) + (string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su")))) + (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit")) + (when (assoc m tramp-methods) (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root")) (should - (string-equal (file-remote-p (format "/%s::" m) 'host) (system-name)))) - (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp" "nc")) + (string-equal (file-remote-p (format "/%s::" m) 'host) (system-name))))) + (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp" "nc")) + (when (assoc m tramp-methods) (should (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name))))) @@ -2128,21 +2132,22 @@ is greater than 10. ;; Host names must match rules in case the command template of a ;; method doesn't use them. (dolist (m '("su" "sg" "sudo" "doas" "ksu")) - (let (tramp-connection-properties tramp-default-proxies-alist) - (ignore-errors - (tramp-cleanup-connection tramp-test-vec nil 'keep-password)) - ;; Single hop. The host name must match `tramp-local-host-regexp'. - (should-error - (find-file (format "/%s:foo:" m)) - :type 'user-error) - ;; Multi hop. The host name must match the previous hop. - (should-error - (find-file - (format - "%s|%s:foo:" - (substring (file-remote-p ert-remote-temporary-file-directory) 0 -1) - m)) - :type 'user-error)))) + (when (assoc m tramp-methods) + (let (tramp-connection-properties tramp-default-proxies-alist) + (ignore-errors + (tramp-cleanup-connection tramp-test-vec nil 'keep-password)) + ;; Single hop. The host name must match `tramp-local-host-regexp'. + (should-error + (find-file (format "/%s:foo:" m)) + :type 'user-error) + ;; Multi hop. The host name must match the previous hop. + (should-error + (find-file + (format + "%s|%s:foo:" + (substring (file-remote-p ert-remote-temporary-file-directory) 0 -1) + m)) + :type 'user-error))))) (ert-deftest tramp-test03-file-name-method-rules () "Check file name rules for some methods." @@ -7064,7 +7069,7 @@ This is used in tests which we don't want to tag "Check, whether a container method is used. This does not support some special file names." (string-match-p - (rx bol (| "docker" "podman")) + (rx bol (| "docker" "podman" "apptainer")) (file-remote-p ert-remote-temporary-file-directory 'method))) (defun tramp--test-container-oob-p () @@ -7233,8 +7238,14 @@ This requires restrictions of file name syntax." (defun tramp--test-supports-processes-p () "Return whether the method under test supports external processes." - (and (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p)) - (not (tramp--test-crypt-p)))) + ;; We use it to enable/disable tests in a given test run, for + ;; example for remote processes on MS Windows. + (if (tramp-connection-property-p + tramp-test-vec "tramp--test-supports-processes-p") + (tramp-get-connection-property + tramp-test-vec "tramp--test-supports-processes-p") + (and (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p)) + (not (tramp--test-crypt-p))))) (defun tramp--test-supports-set-file-modes-p () "Return whether the method under test supports setting file modes." diff --git a/test/lisp/progmodes/csharp-mode-resources/indent-ts.erts b/test/lisp/progmodes/csharp-mode-resources/indent-ts.erts new file mode 100644 index 00000000000..3cb23608270 --- /dev/null +++ b/test/lisp/progmodes/csharp-mode-resources/indent-ts.erts @@ -0,0 +1,51 @@ +Code: + (lambda () + (csharp-ts-mode) + (indent-region (point-min) (point-max))) + +Point-Char: | + +Name: Indent single statement body for if/else. (bug#70345) + +=-= + +int x; +int y; + +if (true) + x = 2; + +if (true) +{ + x = 2; +} + +if (true) + x = 2; +else + y = 2; + +if (true) +{ + x = 2; +} +else +{ + y = 2; +} + +if (true) + x = 2; +else +{ + y = 2; +} + +if (true) +{ + x = 2; +} +else + y = 2; + +=-=-= diff --git a/test/lisp/progmodes/csharp-mode-resources/indent.erts b/test/lisp/progmodes/csharp-mode-resources/indent.erts index a676ecc9728..e03ba80d709 100644 --- a/test/lisp/progmodes/csharp-mode-resources/indent.erts +++ b/test/lisp/progmodes/csharp-mode-resources/indent.erts @@ -16,4 +16,82 @@ public class Foo { } // [2] } } + +public class Foo { + void Bar () { + var x = new X(); + for (;;) { + x(); + } // [2] + } +} + +public class Foo { + void Bar () { + var x = new X() + { + var b = 3; + }; + for (;;) { + x(); + } // [2] + } +} + +public class Foo { + void Bar () { + var x = new X() // Hello + { + var b = 3; + }; + for (;;) { + x(); + } // [2] + } +} + +public class Foo { + void Bar () { + var x = new X() // Hello ; + { + var b = 3; + }; + for (;;) { + x(); + } // [2] + } +} + +public class Foo { + void Bar () { + var x = new X // Hello ; + { + var b = 3; + }; + for (;;) { + x(); + } // [2] + } +} + +public class Foo { + void Bar () { + var x = new X(); // Hello ; + for (;;) { + x(); + } // [2] + } +} + +public class Foo +{ + void Bar () + { + var x = new X(); // Hello ; + for (;;) + { + x(); + } // [2] + } +} =-=-= diff --git a/test/lisp/progmodes/csharp-mode-tests.el b/test/lisp/progmodes/csharp-mode-tests.el index f50fabf5836..af06a918f6e 100644 --- a/test/lisp/progmodes/csharp-mode-tests.el +++ b/test/lisp/progmodes/csharp-mode-tests.el @@ -26,5 +26,9 @@ (ert-deftest csharp-mode-test-indentation () (ert-test-erts-file (ert-resource-file "indent.erts"))) +(ert-deftest csharp-ts-mode-test-indentation () + (skip-unless (treesit-ready-p 'c-sharp t)) + (ert-test-erts-file (ert-resource-file "indent-ts.erts"))) + (provide 'csharp-mode-tests) ;;; csharp-mode-tests.el ends here diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 4725885038e..af1ee998919 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -230,7 +230,7 @@ directory hierarchy." `(push message ,client-replies))))))))) (unwind-protect (progn - (add-hook 'jsonrpc-event-hook #',log-event-hook-sym) + (add-hook 'jsonrpc-event-hook #',log-event-hook-sym t) ,@body) (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym)))))) @@ -436,6 +436,56 @@ directory hierarchy." (flymake-goto-next-error 1 '() t) (should (eq 'flymake-error (face-at-point))))))) +(ert-deftest eglot-test-basic-symlink () + "Test basic symlink support." + (skip-unless (executable-find "clangd")) + ;; MS-Windows either fails symlink creation or pops up UAC prompts. + (skip-when (eq system-type 'windows-nt)) + (eglot--with-fixture + `(("symlink-project" . + (("main.cpp" . "#include\"foo.h\"\nint main() { return foo(); }") + ("foo.h" . "int foo();")))) + (with-current-buffer + (find-file-noselect "symlink-project/main.cpp") + (make-symbolic-link "main.cpp" "mainlink.cpp") + (eglot--tests-connect) + (eglot--sniffing (:client-notifications c-notifs) + (let ((eglot-autoshutdown nil)) (kill-buffer (current-buffer))) + (eglot--wait-for (c-notifs 10) + (&key method &allow-other-keys) + (and (string= method "textDocument/didClose"))))) + (eglot--sniffing (:client-notifications c-notifs) + (with-current-buffer + (find-file-noselect "symlink-project/main.cpp") + (should (eglot-current-server))) + (eglot--wait-for (c-notifs 10) + (&rest whole &key params method &allow-other-keys) + (and (string= method "textDocument/didOpen") + (string-match "main.cpp$" + (plist-get (plist-get params :textDocument) + :uri))))) + ;; This last segment is deactivated, because it's likely not needed. + ;; The only way the server would answer with '3' references is if we + ;; had erroneously sent a 'didOpen' for anything other than + ;; `main.cpp', but if we got this far is because we've just asserted + ;; that we didn't. + (when nil + (with-current-buffer + (find-file-noselect "symlink-project/foo.h") + ;; Give clangd some time to settle its analysis so it can + ;; accurately respond to `textDocument/references' + (sleep-for 3) + (search-forward "foo") + (eglot--sniffing (:server-replies s-replies) + (call-interactively 'xref-find-references) + (eglot--wait-for (s-replies 10) + (&key method result &allow-other-keys) + ;; Expect xref buffer to not contain duplicate references to + ;; main.cpp and mainlink.cpp. If it did, 'result's length + ;; would be 3. + (and (string= method "textDocument/references") + (= (length result) 2)))))))) + (ert-deftest eglot-test-diagnostic-tags-unnecessary-code () "Test rendering of diagnostics tagged \"unnecessary\"." (skip-unless (executable-find "clangd")) @@ -821,6 +871,12 @@ int main() { (should (looking-back "\"foo.bar\": \"")) (should (looking-at "fb\"$")))))) +(defun eglot-tests--get (object path) + (dolist (op path) + (setq object (if (natnump op) (aref object op) + (plist-get object op)))) + object) + (defun eglot-tests--lsp-abiding-column-1 () (eglot--with-fixture '(("project" . @@ -837,7 +893,11 @@ int main() { (insert "p ") (eglot--signal-textDocument/didChange) (eglot--wait-for (c-notifs 2) (&key params &allow-other-keys) - (should (equal 71 (cadddr (cadadr (aref (cadddr params) 0)))))) + (message "PARAMS=%S" params) + (should (equal 71 (eglot-tests--get + params + '(:contentChanges 0 + :range :start :character))))) (beginning-of-line) (should (eq eglot-move-to-linepos-function #'eglot-move-to-utf-16-linepos)) (funcall eglot-move-to-linepos-function 71) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 1d1ef9981e5..591c32a8271 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -1131,5 +1131,14 @@ evaluation of BODY." (emacs-lisp-mode) (indent-region (point-min) (point-max))))) +(ert-deftest elisp-tests-syntax-propertize () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(a '@)") ;bug#24542 + (should (equal (scan-sexps (+ (point-min) 3) 1) (1- (point-max)))) + (erase-buffer) + (insert "(a ,@)") + (should-error (scan-sexps (+ (point-min) 3) 1)))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/lua-ts-mode-resources/indent.erts b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts index 48184160b4d..ba7bad1b452 100644 --- a/test/lisp/progmodes/lua-ts-mode-resources/indent.erts +++ b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts @@ -66,6 +66,10 @@ end return f end +f6(function() +print'ok' +end) + ;(function () return true end)() @@ -118,6 +122,10 @@ function f6(...) return f end +f6(function() + print'ok' +end) + ;(function () return true end)() @@ -406,6 +414,15 @@ a = 1, b = 2, }, nil) + +Test(nil, { + a = 1, + b = 2, + }) + +fn( -- comment + 1, + 2) =-= h( "string", @@ -443,6 +460,15 @@ Test({ b = 2, }, nil) + +Test(nil, { + a = 1, + b = 2, +}) + +fn( -- comment + 1, + 2) =-=-= Name: Parameter Indent @@ -464,6 +490,9 @@ local f3 = function( a, b, c, d ) print(a,b,c,d) end + +local f4 = function(-- comment +a, b, c) =-= function f1( a, @@ -481,6 +510,9 @@ local f3 = function( a, b, c, d ) print(a,b,c,d) end + +local f4 = function(-- comment + a, b, c) =-=-= Name: Table Indent @@ -506,6 +538,10 @@ a = 1, b = 2, c = 3, } + +local a = { -- hello world! + b = 10 +} =-= local Other = { First={up={Step=true,Jump=true}, @@ -527,6 +563,10 @@ local Other = { b = 2, c = 3, } + +local a = { -- hello world! + b = 10 +} =-=-= Name: Continuation Indent diff --git a/test/lisp/progmodes/lua-ts-mode-resources/which-function.lua b/test/lisp/progmodes/lua-ts-mode-resources/which-function.lua new file mode 100644 index 00000000000..621d818461c --- /dev/null +++ b/test/lisp/progmodes/lua-ts-mode-resources/which-function.lua @@ -0,0 +1,3 @@ +local function f(x) + print(x) +end diff --git a/test/lisp/progmodes/lua-ts-mode-tests.el b/test/lisp/progmodes/lua-ts-mode-tests.el index 565e6f91dbd..68b8c9ccfaa 100644 --- a/test/lisp/progmodes/lua-ts-mode-tests.el +++ b/test/lisp/progmodes/lua-ts-mode-tests.el @@ -23,20 +23,31 @@ (require 'ert-font-lock) (require 'ert-x) (require 'treesit) +(require 'which-func) (ert-deftest lua-ts-test-indentation () - (skip-unless (treesit-ready-p 'lua)) + (skip-unless (treesit-ready-p 'lua t)) (ert-test-erts-file (ert-resource-file "indent.erts"))) (ert-deftest lua-ts-test-movement () - (skip-unless (treesit-ready-p 'lua)) + (skip-unless (treesit-ready-p 'lua t)) (ert-test-erts-file (ert-resource-file "movement.erts"))) (ert-deftest lua-ts-test-font-lock () - (skip-unless (treesit-ready-p 'lua)) + (skip-unless (treesit-ready-p 'lua t)) (let ((treesit-font-lock-level 4)) (ert-font-lock-test-file (ert-resource-file "font-lock.lua") 'lua-ts-mode))) +(ert-deftest lua-ts-test-which-function () + (skip-unless (treesit-ready-p 'lua t)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "which-function.lua")) + (lua-ts-mode) + (which-function-mode) + (goto-char (point-min)) + (should (equal "f" (which-function))) + (which-function-mode -1))) + (provide 'lua-ts-mode-tests) ;;; lua-ts-mode-tests.el ends here diff --git a/test/lisp/progmodes/peg-tests.el b/test/lisp/progmodes/peg-tests.el new file mode 100644 index 00000000000..e666e6f19d2 --- /dev/null +++ b/test/lisp/progmodes/peg-tests.el @@ -0,0 +1,386 @@ +;;; peg-tests.el --- Tests of PEG parsers -*- lexical-binding: t; -*- + +;; Copyright (C) 2008-2024 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests and examples, that used to live in peg.el wrapped inside an `eval'. + +;;; Code: + +(require 'peg) +(require 'ert) + +;;; Tests: + +(defmacro peg-parse-string (pex string &optional noerror) + "Parse STRING according to PEX. +If NOERROR is non-nil, push nil resp. t if the parse failed +resp. succeeded instead of signaling an error." + (declare (indent 1)) + (let ((oldstyle (consp (car-safe pex)))) ;PEX is really a list of rules. + `(with-temp-buffer + (insert ,string) + (goto-char (point-min)) + ,(if oldstyle + `(with-peg-rules ,pex + (peg-run (peg ,(caar pex)) + ,(unless noerror '#'peg-signal-failure))) + `(peg-run (peg ,pex) + ,(unless noerror '#'peg-signal-failure)))))) + +(define-peg-rule peg-test-natural () + [0-9] (* [0-9])) + +(ert-deftest peg-test () + (should (peg-parse-string peg-test-natural "99 bottles" t)) + (should (peg-parse-string ((s "a")) "a" t)) + (should (not (peg-parse-string ((s "a")) "b" t))) + (should (peg-parse-string ((s (not "a"))) "b" t)) + (should (not (peg-parse-string ((s (not "a"))) "a" t))) + (should (peg-parse-string ((s (if "a"))) "a" t)) + (should (not (peg-parse-string ((s (if "a"))) "b" t))) + (should (peg-parse-string ((s "ab")) "ab" t)) + (should (not (peg-parse-string ((s "ab")) "ba" t))) + (should (not (peg-parse-string ((s "ab")) "a" t))) + (should (peg-parse-string ((s (range ?0 ?9))) "0" t)) + (should (not (peg-parse-string ((s (range ?0 ?9))) "a" t))) + (should (peg-parse-string ((s [0-9])) "0" t)) + (should (not (peg-parse-string ((s [0-9])) "a" t))) + (should (not (peg-parse-string ((s [0-9])) "" t))) + (should (peg-parse-string ((s (any))) "0" t)) + (should (not (peg-parse-string ((s (any))) "" t))) + (should (peg-parse-string ((s (eob))) "" t)) + (should (peg-parse-string ((s (not (eob)))) "a" t)) + (should (peg-parse-string ((s (or "a" "b"))) "a" t)) + (should (peg-parse-string ((s (or "a" "b"))) "b" t)) + (should (not (peg-parse-string ((s (or "a" "b"))) "c" t))) + (should (peg-parse-string (and "a" "b") "ab" t)) + (should (peg-parse-string ((s (and "a" "b"))) "abc" t)) + (should (not (peg-parse-string (and "a" "b") "ba" t))) + (should (peg-parse-string ((s (and "a" "b" "c"))) "abc" t)) + (should (peg-parse-string ((s (* "a") "b" (eob))) "b" t)) + (should (peg-parse-string ((s (* "a") "b" (eob))) "ab" t)) + (should (peg-parse-string ((s (* "a") "b" (eob))) "aaab" t)) + (should (not (peg-parse-string ((s (* "a") "b" (eob))) "abc" t))) + (should (peg-parse-string ((s "")) "abc" t)) + (should (peg-parse-string ((s "" (eob))) "" t)) + (should (peg-parse-string ((s (opt "a") "b")) "abc" t)) + (should (peg-parse-string ((s (opt "a") "b")) "bc" t)) + (should (not (peg-parse-string ((s (or))) "ab" t))) + (should (peg-parse-string ((s (and))) "ab" t)) + (should (peg-parse-string ((s (and))) "" t)) + (should (peg-parse-string ((s ["^"])) "^" t)) + (should (peg-parse-string ((s ["^a"])) "a" t)) + (should (peg-parse-string ["-"] "-" t)) + (should (peg-parse-string ((s ["]-"])) "]" t)) + (should (peg-parse-string ((s ["^]"])) "^" t)) + (should (peg-parse-string ((s [alpha])) "z" t)) + (should (not (peg-parse-string ((s [alpha])) "0" t))) + (should (not (peg-parse-string ((s [alpha])) "" t))) + (should (not (peg-parse-string ((s ["][:alpha:]"])) "z" t))) + (should (peg-parse-string ((s (bob))) "" t)) + (should (peg-parse-string ((s (bos))) "x" t)) + (should (not (peg-parse-string ((s (bos))) " x" t))) + (should (peg-parse-string ((s "x" (eos))) "x" t)) + (should (peg-parse-string ((s (syntax-class whitespace))) " " t)) + (should (peg-parse-string ((s (= "foo"))) "foo" t)) + (should (let ((f "foo")) (peg-parse-string ((s (= f))) "foo" t))) + (should (not (peg-parse-string ((s (= "foo"))) "xfoo" t))) + (should (equal (peg-parse-string ((s `(-- 1 2))) "") '(2 1))) + (should (equal (peg-parse-string ((s `(-- 1 2) `(a b -- a b))) "") '(2 1))) + (should (equal (peg-parse-string ((s (or (and (any) s) + (substring [0-9])))) + "ab0cd1ef2gh") + '("2"))) + ;; The PEG rule `doesntexist' doesn't exist, which will cause a byte-compiler + ;; warning, but not an error at run time because the rule is not actually + ;; used in this particular case. + (let* ((testfun '(lambda () + (peg-parse-string ((s (substring (or "a" doesntexist))) + ;; Unused left-recursive rule, should + ;; cause a byte-compiler warning. + (r (* "a") r)) + "af"))) + (compiledfun + (progn + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer))) + (let ((lexical-binding t)) (byte-compile testfun))))) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (goto-char (point-min)) + (should + ;; FIXME: The byte-compiler emits "not known to be defined" + ;; warnings when compiling a file but not from `byte-compile'. + ;; Instead, we have to dig it out of the mess it leaves behind. 🙂 + (or (assq 'peg-rule\ doesntexist byte-compile-unresolved-functions) + (should (re-search-forward + "peg-rule.? doesntexist.*not known to be defined" nil t)))) + (goto-char (point-min)) + (should (re-search-forward "left recursion.*r -> r" nil t))) + + (should (equal (funcall compiledfun) '("a")))) + (should (equal (peg-parse-string ((s (list x y)) + (x `(-- 1)) + (y `(-- 2))) + "") + '((1 2)))) + (should (equal (peg-parse-string ((s (list (* x))) + (x "" `(-- 'x))) + "xxx") + ;; The empty loop body should be matched once! + '((x)))) + (should (equal (peg-parse-string ((s (list (* x))) + (x "x" `(-- 'x))) + "xxx") + '((x x x)))) + (should (equal (peg-parse-string ((s (region (* x))) + (x "x" `(-- 'x))) + "xxx") + ;; FIXME: Since string positions start at 0, this should + ;; really be '(3 x x x 0) !! + '(4 x x x 1))) + (should (equal (peg-parse-string ((s (region (list (* x)))) + (x "x" `(-- 'x 'y))) + "xxx") + '(4 (x y x y x y) 1))) + (should (equal (with-temp-buffer + (save-excursion (insert "abcdef")) + (list + (peg-run (peg "a" + (replace "bc" "x") + (replace "de" "y") + "f")) + (buffer-string))) + '(t "axyf"))) + (with-temp-buffer + (insert "toro") + (goto-char (point-min)) + (should (peg-run (peg "to"))) + (should-not (peg-run (peg "to"))) + (should (peg-run (peg "ro"))) + (should (eobp))) + (with-temp-buffer + (insert " ") + (goto-char (point-min)) + (peg-run (peg (+ (syntax-class whitespace)))) + (should (eobp))) + ) + +;;; Examples: + +;; peg-ex-recognize-int recognizes integers. An integer begins with a +;; optional sign, then follows one or more digits. Digits are all +;; characters from 0 to 9. +;; +;; Notes: +;; 1) "" matches the empty sequence, i.e. matches without consuming +;; input. +;; 2) [0-9] is the character range from 0 to 9. This can also be +;; written as (range ?0 ?9). Note that 0-9 is a symbol. +(defun peg-ex-recognize-int () + (with-peg-rules ((number sign digit (* digit)) + (sign (or "+" "-" "")) + (digit [0-9])) + (peg-run (peg number)))) + +;; peg-ex-parse-int recognizes integers and computes the corresponding +;; value. The grammar is the same as for `peg-ex-recognize-int' +;; augmented with parsing actions. Unfortunaletly, the actions add +;; quite a bit of clutter. +;; +;; The actions for the sign rule push -1 on the stack for a minus sign +;; and 1 for plus or no sign. +;; +;; The action for the digit rule pushes the value for a single digit. +;; +;; The action `(a b -- (+ (* a 10) b)), takes two items from the stack +;; and pushes the first digit times 10 added to the second digit. +;; +;; The action `(sign val -- (* sign val)), multiplies val with the +;; sign (1 or -1). +(defun peg-ex-parse-int () + (with-peg-rules ((number sign digit (* digit + `(a b -- (+ (* a 10) b))) + `(sign val -- (* sign val))) + (sign (or (and "+" `(-- 1)) + (and "-" `(-- -1)) + (and "" `(-- 1)))) + (digit [0-9] `(-- (- (char-before) ?0)))) + (peg-run (peg number)))) + +;; Put point after the ) and press C-x C-e +;; (peg-ex-parse-int)-234234 + +;; Parse arithmetic expressions and compute the result as side effect. +(defun peg-ex-arith () + (peg-parse + (expr _ sum eol) + (sum product (* (or (and "+" _ product `(a b -- (+ a b))) + (and "-" _ product `(a b -- (- a b)))))) + (product value (* (or (and "*" _ value `(a b -- (* a b))) + (and "/" _ value `(a b -- (/ a b)))))) + (value (or (and (substring number) `(string -- (string-to-number string))) + (and "(" _ sum ")" _))) + (number (+ [0-9]) _) + (_ (* [" \t"])) + (eol (or "\n" "\r\n" "\r")))) + +;; (peg-ex-arith) 1 + 2 * 3 * (4 + 5) +;; (peg-ex-arith) 1 + 2 ^ 3 * (4 + 5) ; fails to parse + +;; Parse URI according to RFC 2396. +(defun peg-ex-uri () + (peg-parse + (URI-reference (or absoluteURI relativeURI) + (or (and "#" (substring fragment)) + `(-- nil)) + `(scheme user host port path query fragment -- + (list :scheme scheme :user user + :host host :port port + :path path :query query + :fragment fragment))) + (absoluteURI (substring scheme) ":" (or hier-part opaque-part)) + (hier-part ;(-- user host port path query) + (or net-path + (and `(-- nil nil nil) + abs-path)) + (or (and "?" (substring query)) + `(-- nil))) + (net-path "//" authority (or abs-path `(-- nil))) + (abs-path "/" path-segments) + (path-segments segment (list (* "/" segment)) `(s l -- (cons s l))) + (segment (substring (* pchar) (* ";" param))) + (param (* pchar)) + (pchar (or unreserved escaped [":@&=+$,"])) + (query (* uric)) + (fragment (* uric)) + (relativeURI (or net-path abs-path rel-path) (opt "?" query)) + (rel-path rel-segment (opt abs-path)) + (rel-segment (+ unreserved escaped [";@&=+$,"])) + (authority (or server reg-name)) + (server (or (and (or (and (substring userinfo) "@") + `(-- nil)) + hostport) + `(-- nil nil nil))) + (userinfo (* (or unreserved escaped [";:&=+$,"]))) + (hostport (substring host) (or (and ":" (substring port)) + `(-- nil))) + (host (or hostname ipv4address)) + (hostname (* domainlabel ".") toplabel (opt ".")) + (domainlabel alphanum + (opt (* (or alphanum "-") (if alphanum)) + alphanum)) + (toplabel alpha + (* (or alphanum "-") (if alphanum)) + alphanum) + (ipv4address (+ digit) "." (+ digit) "." (+ digit) "." (+ digit)) + (port (* digit)) + (scheme alpha (* (or alpha digit ["+-."]))) + (reg-name (or unreserved escaped ["$,;:@&=+"])) + (opaque-part uric-no-slash (* uric)) + (uric (or reserved unreserved escaped)) + (uric-no-slash (or unreserved escaped [";?:@&=+$,"])) + (reserved (set ";/?:@&=+$,")) + (unreserved (or alphanum mark)) + (escaped "%" hex hex) + (hex (or digit [A-F] [a-f])) + (mark (set "-_.!~*'()")) + (alphanum (or alpha digit)) + (alpha (or lowalpha upalpha)) + (lowalpha [a-z]) + (upalpha [A-Z]) + (digit [0-9]))) + +;; (peg-ex-uri)http://luser@www.foo.com:8080/bar/baz.html?x=1#foo +;; (peg-ex-uri)file:/bar/baz.html?foo=df#x + +;; Split STRING where SEPARATOR occurs. +(defun peg-ex-split (string separator) + (peg-parse-string ((s (list (* (* sep) elt))) + (elt (substring (+ (not sep) (any)))) + (sep (= separator))) + string)) + +;; (peg-ex-split "-abc-cd-" "-") + +;; Parse a lisp style Sexp. +;; [To keep the example short, ' and . are handled as ordinary symbol.] +(defun peg-ex-lisp () + (peg-parse + (sexp _ (or string list number symbol)) + (_ (* (or [" \n\t"] comment))) + (comment ";" (* (not (or "\n" (eob))) (any))) + (string "\"" (substring (* (not "\"") (any))) "\"") + (number (substring (opt (set "+-")) (+ digit)) + (if terminating) + `(string -- (string-to-number string))) + (symbol (substring (and symchar (* (not terminating) symchar))) + `(s -- (intern s))) + (symchar [a-z A-Z 0-9 "-;!#%&'*+,./:;<=>?@[]^_`{|}~"]) + (list "(" `(-- (cons nil nil)) `(hd -- hd hd) + (* sexp `(tl e -- (setcdr tl (list e)))) + _ ")" `(hd _tl -- (cdr hd))) + (digit [0-9]) + (terminating (or (set " \n\t();\"'") (eob))))) + +;; (peg-ex-lisp) + +;; We try to detect left recursion and report it as error. +(defun peg-ex-left-recursion () + (eval '(peg-parse (exp (or term + (and exp "+" exp))) + (term (or digit + (and term "*" term))) + (digit [0-9])) + t)) + +(defun peg-ex-infinite-loop () + (eval '(peg-parse (exp (* (or "x" + "y" + (action (foo)))))) + t)) + +;; Some efficiency problems: + +;; Find the last digit in a string. +;; Recursive definition with excessive stack usage. +(defun peg-ex-last-digit (string) + (peg-parse-string ((s (or (and (any) s) + (substring [0-9])))) + string)) + +;; (peg-ex-last-digit "ab0cd1ef2gh") +;; (peg-ex-last-digit (make-string 50 ?-)) +;; (peg-ex-last-digit (make-string 1000 ?-)) + +;; Find the last digit without recursion. Doesn't run out of stack, +;; but probably still too inefficient for large inputs. +(defun peg-ex-last-digit2 (string) + (peg-parse-string ((s `(-- nil) + (+ (* (not digit) (any)) + (substring digit) + `(_d1 d2 -- d2))) + (digit [0-9])) + string)) + +;; (peg-ex-last-digit2 "ab0cd1ef2gh") +;; (peg-ex-last-digit2 (concat (make-string 500000 ?-) "8a9b")) +;; (peg-ex-last-digit2 (make-string 500000 ?-)) +;; (peg-ex-last-digit2 (make-string 500000 ?5)) + +(provide 'peg-tests) +;;; peg-tests.el ends here diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index 04cdf1dea29..21703cbdad6 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -163,4 +163,29 @@ When `project-ignores' includes a name matching project dir." (should-not (null project)) (should (string-match-p "/test/lisp/progmodes/project-resources/\\'" (project-root project))))) +(ert-deftest project-find-regexp () + "Check the happy path." + (skip-unless (executable-find find-program)) + (skip-unless (executable-find "xargs")) + (skip-unless (executable-find "grep")) + (let* ((directory (ert-resource-directory)) + (project-find-functions nil) + (project-list-file (expand-file-name "emacs-projects" temporary-file-directory)) + (project (cons 'transient directory))) + (add-hook 'project-find-functions (lambda (_dir) project)) + (should (eq (project-current) project)) + (let* ((matches nil) + (xref-search-program 'grep) + (xref-show-xrefs-function + (lambda (fetcher _display) + (setq matches (funcall fetcher))))) + (project-find-regexp "etc") + (should (equal (mapcar (lambda (item) + (file-name-base + (xref-location-group (xref-item-location item)))) + matches) + '(".dir-locals" "etc"))) + (should (equal (sort (mapcar #'xref-item-summary matches) #'string<) + '("((nil . ((project-vc-ignores . (\"etc\")))))" "etc")))))) + ;;; project-tests.el ends here diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index e11440cdb5b..f50797953c3 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -4896,7 +4896,8 @@ def foo(): (ert-deftest python-shell-completion-at-point-ipython () "Check if Python shell completion works for IPython." - (let ((python-shell-interpreter "ipython") + (let ((python-tests-shell-interpreter "ipython") + (python-shell-interpreter "ipython") (python-shell-interpreter-args "-i --simple-prompt")) (skip-unless (and @@ -7465,6 +7466,33 @@ buffer with overlapping strings." "Unused import a.b.c (unused-import)" "W0611: Unused import a.b.c (unused-import)")))))) +(ert-deftest python-test--shell-send-block () + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-buffer-with-shell + "print('current 0') +for x in range(1,3): + print('current %s' % x) +print('current 3')" + (goto-char (point-min)) + (should-error (python-shell-send-block) :type 'user-error) + (forward-line) + (python-shell-send-block) + (python-tests-shell-wait-for-prompt) + (python-shell-with-shell-buffer + (goto-char (point-min)) + (should-not (re-search-forward "current 0" nil t)) + (should (re-search-forward "current 1" nil t)) + (should (re-search-forward "current 2" nil t)) + (should-not (re-search-forward "current 3" nil t))) + (forward-line) + (python-shell-send-block t) ;; send block body only + (python-tests-shell-wait-for-prompt) + (python-shell-with-shell-buffer + ;; should only 1 line output from the block body + (should (re-search-forward "current")) + (should (looking-at " 2")) + (should-not (re-search-forward "current" nil t))))) + ;;; python-ts-mode font-lock tests (defmacro python-ts-tests-with-temp-buffer (contents &rest body) @@ -7545,6 +7573,9 @@ always located at the beginning of buffer." (ert-deftest python-ts-mode-types-face-1 () (python-ts-tests-with-temp-buffer "def f(val: Callable[[Type0], (Type1, Type2)]):" + (search-forward "val") + (goto-char (match-beginning 0)) + (should (eq (face-at-point) font-lock-variable-name-face)) (dolist (test '("Callable" "Type0" "Type1" "Type2")) (search-forward test) (goto-char (match-beginning 0)) diff --git a/test/lisp/progmodes/rust-ts-mode-resources/font-lock.rs b/test/lisp/progmodes/rust-ts-mode-resources/font-lock.rs new file mode 100644 index 00000000000..377cda0e3b9 --- /dev/null +++ b/test/lisp/progmodes/rust-ts-mode-resources/font-lock.rs @@ -0,0 +1,25 @@ +// -*- rust-ts-mode-indent-offset: 0 -*- +// Trait with function signature +trait Foo { + fn foo(); +// ^ font-lock-function-name-face +} + +// Macros +macro_rules! unsafe_foo { + ($env:expr, $name:ident $(, $args:expr)*) => { +// ^ font-lock-variable-name-face +// ^ font-lock-type-face +// ^ font-lock-variable-name-face +// ^ font-lock-type-face +// ^ font-lock-operator-face +// ^ font-lock-variable-name-face +// ^ font-lock-type-face +// ^ font-lock-operator-face + { + foo!($env, $name $(, $args)*); +// ^ font-lock-variable-use-face +// ^ font-lock-operator-face +// ^ font-lock-operator-face + } + }; diff --git a/test/lisp/progmodes/rust-ts-mode-tests.el b/test/lisp/progmodes/rust-ts-mode-tests.el new file mode 100644 index 00000000000..f718a57fc9e --- /dev/null +++ b/test/lisp/progmodes/rust-ts-mode-tests.el @@ -0,0 +1,34 @@ +;;; rust-ts-mode-tests.el --- Tests for rust-ts-mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2023-2024 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 'ert-font-lock) +(require 'ert-x) +(require 'treesit) + +(ert-deftest rust-ts-test-font-lock () + (skip-unless (treesit-ready-p 'rust)) + (let ((treesit-font-lock-level 4)) + (ert-font-lock-test-file (ert-resource-file "font-lock.rs") 'rust-ts-mode))) + +(provide 'rust-ts-mode-tests) + +;;; rust-ts-mode-tests.el ends here diff --git a/test/lisp/progmodes/sh-script-resources/sh-indents.erts b/test/lisp/progmodes/sh-script-resources/sh-indents.erts index 36f4e4c22ab..5a72df0e7ef 100644 --- a/test/lisp/progmodes/sh-script-resources/sh-indents.erts +++ b/test/lisp/progmodes/sh-script-resources/sh-indents.erts @@ -1,6 +1,10 @@ Code: (lambda () (shell-script-mode) + (unless sh-indent-supported-here + (ert-skip + '((skip-unless sh-indent-supported-here) + :form sh-indent-supported-here :value nil))) (indent-region (point-min) (point-max))) Name: sh-indents1 diff --git a/test/lisp/progmodes/sh-script-tests.el b/test/lisp/progmodes/sh-script-tests.el index e73d52399d3..45add34a111 100644 --- a/test/lisp/progmodes/sh-script-tests.el +++ b/test/lisp/progmodes/sh-script-tests.el @@ -30,6 +30,7 @@ (insert "relative-path/to/configure --prefix=$prefix\\ --with-x") (shell-script-mode) + (skip-unless sh-indent-supported-here) (goto-char (point-min)) (forward-line 1) (indent-for-tab-command) @@ -42,6 +43,7 @@ (with-temp-buffer (insert "myecho () {\necho foo\n}\n") (shell-script-mode) + (skip-unless sh-indent-supported-here) (indent-region (point-min) (point-max)) (should (equal (buffer-string) "myecho () { @@ -56,6 +58,7 @@ (with-temp-buffer (insert "for f \\\nin a; do \\\ntoto; \\\ndone\n") (shell-script-mode) + (skip-unless sh-indent-supported-here) (let ((sh-indent-for-continuation '++)) (let ((sh-indent-after-continuation t)) (indent-region (point-min) (point-max)) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 4e3f743cc93..119c124f3a5 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -744,7 +744,14 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (+ subr-tests-var1 subr-tests-var2))) '(let* ((subr-tests-var1 1) (subr-tests-var2 subr-tests-var1)) - (+ subr-tests-var1 subr-tests-var2))))) + (+ subr-tests-var1 subr-tests-var2)))) + ;; Check that the init expression can be omitted, as in `let'/`let*'. + (should (equal (letrec ((a (lambda () (funcall c))) + (b) + (c (lambda () b))) + (setq b 'ok) + (funcall a)) + 'ok))) (defvar subr-tests--hook nil) diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index 7f7c99a40a4..eed00cbbbc3 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -197,10 +197,28 @@ journal = {Some Journal}, year = 2013, pages = {1--333} +}")) + (entry2 (reftex-parse-bibtex-entry "\ +@article{Abels:slice, +author = {Abels, H.}, +title = {Parallelizability of proper actions, global + {$K$}-slices and maximal compact subgroups}, +journaltitle = {Math. Ann.}, +year = 1974, +volume = 212, +pages = {1--19} }"))) (should (string= (reftex-format-citation entry nil) "\\cite{Foo13}")) (should (string= (reftex-format-citation entry "%l:%A:%y:%t %j %P %a") - "Foo13:Jane Roe:2013:Some Article Some Journal 1 Jane Roe, John Doe \\& Jane Taxpayer")))) + "Foo13:Jane Roe:2013:Some Article Some Journal 1 Jane Roe, John Doe \\& Jane Taxpayer")) + ;; Test for biblatex field journaltitle (bug#38762): + (should (string= + (reftex-format-citation entry2 + "[%4a, \\textit{%t}, \ +%b %e, %u, %r %h %j \\textbf{%v} (%y), %p %<]") + "[Abels, \\textit{Parallelizability of proper actions, \ +global {$K$}-slices and maximal compact subgroups}, \ +Math. Ann. \\textbf{212} (1974), 1--19]")))) (ert-deftest reftex-all-used-citation-keys () "Test `reftex-all-used-citation-keys'. @@ -285,6 +303,20 @@ Natbib compatibility commands: \\Citep[pre][pos]{Citep:2022} \\Citep*[pre][pos]{Citep*:2022} +Qualified Citation Lists: +\\cites(Global Prenote)(Global Postnote)[pre][post]{cites:1}[pre][post]{cites:2} +\\Cites(Global Prenote)(Global Postnote)[pre][post]{Cites:1}[pre][post]{Cites:2} +\\parencites(Global Prenote)(Global Postnote)[pre][post]{parencites:1} + [pre][post]{parencites:2} +\\Parencites(Global Prenote)(Global Postnote)[pre][post]{Parencites:1}{Parencites:2} +\\footcites[pre][post]{footcites:1}[pre][post]{footcites:2} +\\footcitetexts{footcitetexts:1}{footcitetexts:2} +\\smartcites{smartcites:1} +% This is comment about \\smartcites{smartcites:2} +[pre][post]{smartcites:2} +% And this should be ignored \\smartcites{smartcites:3}{smartcites:4} + + Test for bug#56655: There was a few \\% of increase in budget \\Citep*{bug:56655}. @@ -331,6 +363,14 @@ And this should be % \\cite{ignored}. "citealp:2022" "citealp*:2022" "Citet:2022" "Citet*:2022" "Citep:2022" "Citep*:2022" + ;; Qualified Citation Lists + "cites:1" "cites:2" + "Cites:1" "Cites:2" + "parencites:1" "parencites:2" + "Parencites:1" "Parencites:2" + "footcites:1" "footcites:2" + "footcitetexts:1" "footcitetexts:2" + "smartcites:1" "smartcites:2" "bug:56655") #'string<))) (kill-buffer (file-name-nondirectory tex-file))))) diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el index 133aa0ffd88..c6246d69a2a 100644 --- a/test/lisp/url/url-util-tests.el +++ b/test/lisp/url/url-util-tests.el @@ -32,7 +32,11 @@ ("key1=val1;key2=val2;key3=val1;key3=val2;key4;key5" ((key1 "val1") (key2 val2) (key3 val1 val2) ("key4") (key5 "")) t) ("key1=val1;key2=val2;key3=val1;key3=val2;key4=;key5=" - ((key1 val1) (key2 val2) ("key3" val1 val2) (key4) (key5 "")) t t))) + ((key1 val1) (key2 val2) ("key3" val1 val2) (key4) (key5 "")) t t) + ("key1=val/slash;key2=val%3Bsemi;key3=val%26amp;key4=val%3Deq" + ((key1 "val/slash") (key2 "val;semi") (key3 "val&") (key4 "val=eq")) t) + ("key%3Deq=val1;key%3Bsemi=val2;key%26amp=val3" + (("key=eq" val1) ("key;semi" val2) ("key&" val3)) t))) test) (while tests (setq test (car tests) diff --git a/test/lisp/vc/log-edit-tests.el b/test/lisp/vc/log-edit-tests.el index 8373156587d..db60d21f137 100644 --- a/test/lisp/vc/log-edit-tests.el +++ b/test/lisp/vc/log-edit-tests.el @@ -344,4 +344,22 @@ next line instead.") (let ((fill-column 20)) (log-edit-fill-entry)) (should (equal (buffer-string) wanted))))) +(ert-deftest log-edit-fill-entry-no-defun-list-wrapping () + ;; This test verifies that the opening defun list of an entry is never + ;; broken, even in the event its length in total exceeds the fill + ;; column. + (let (string wanted) + (setq string " +* src/androidfns.c (Fxw_display_color_p): +(Fx_display_grayscale_p): Report color and/or grayscale properly. +" + wanted " +* src/androidfns.c (Fxw_display_color_p, Fx_display_grayscale_p): +Report color and/or grayscale properly. +") + (with-temp-buffer + (insert string) + (let ((fill-column 64)) (log-edit-fill-entry)) + (should (equal (buffer-string) wanted))))) + ;;; log-edit-tests.el ends here diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index 4b049478b29..d416eb99022 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -336,7 +336,13 @@ return nil, even with a non-nil bubblep argument." (widget-forward 2) (forward-char) (widget-backward 1) - (should (string= "Second" (widget-value (widget-at)))))) + (should (string= "Second" (widget-value (widget-at)))) + ;; Check that moving to a widget at beginning of buffer does not + ;; signal a beginning-of-buffer error (bug#69943). + (widget-backward 1) ; Should not signal beginning-of-buffer error. + (widget-forward 2) + (should (string= "Third" (widget-value (widget-at)))) + (widget-forward 1))) ; Should not signal beginning-of-buffer error. (ert-deftest widget-test-color-match () "Test that the :match function for the color widget works." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b2fd2f68826..5deff03fd84 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -865,8 +865,8 @@ Return a list of results." (let ((native-comp-speed 3) ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets ;; optimized-out. - (comp-disabled-passes '(comp-ipa-pure)) - (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) + (comp-disabled-passes '(comp--ipa-pure)) + (comp-post-pass-hooks '((comp--tco comp-tests-tco-checker) (comp-final comp-tests-tco-checker)))) (eval '(defun comp-tests-tco-f (a b count) (if (= count 0) @@ -893,7 +893,7 @@ Return a list of results." (comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((native-comp-speed 2) - (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) + (comp-post-pass-hooks '((comp--final comp-tests-fw-prop-checker-1)))) (eval '(defun comp-tests-fw-prop-1-f () (let* ((a "xxx") (b "yyy") @@ -1550,8 +1550,8 @@ folded." (comp-deftest pure () "Some tests for pure functions optimization." (let ((native-comp-speed 3) - (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 - comp-tests-pure-checker-2)))) + (comp-post-pass-hooks '((comp--final comp-tests-pure-checker-1 + comp-tests-pure-checker-2)))) (load (native-compile (ert-resource-file "comp-test-pure.el"))) (declare-function comp-tests-pure-caller-f nil) (declare-function comp-tests-pure-fibn-entry-f nil) diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index b3b7da65ad3..a02bab73c09 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -426,4 +426,112 @@ (should (= (field-beginning) 7)) (should (= (field-end) (point-max))))) +;;; Try and catch `*-changes-functions' bugs! + +(defvar sanity-check-change-functions-verbose nil) +(defvar sanity-check-change-functions-op nil) +(defmacro sanity-check-change-functions-with-op (op &rest body) + (declare (debug t) (indent 1)) + `(let ((sanity-check-change-functions-op ,op)) + (sanity-check--message "%S..." sanity-check-change-functions-op) + ,@body + (sanity-check--message "%S...done" sanity-check-change-functions-op))) + +(defun sanity-check--message (&rest args) + (if sanity-check-change-functions-verbose (apply #'message args))) + +(defvar-local sanity-check-change-functions-beg 0) +(defvar-local sanity-check-change-functions-end 0) +(defvar-local sanity-check-change-functions-buffer-size nil) +(defvar sanity-check-change-functions-errors nil) + +(defun sanity-check-change-functions-error (description &rest args) + (push (apply #'format description args) + sanity-check-change-functions-errors)) + +(defun sanity-check-change-functions-check-size () + (sanity-check--message "Size : %S == %S" + sanity-check-change-functions-buffer-size + (buffer-size)) + (cond + ((null sanity-check-change-functions-buffer-size) + (setq sanity-check-change-functions-buffer-size (buffer-size))) + ((equal sanity-check-change-functions-buffer-size (buffer-size)) nil) + (t + (sanity-check-change-functions-error + "buffer-size %S == %S" + (buffer-size) sanity-check-change-functions-buffer-size) + (setq sanity-check-change-functions-buffer-size (buffer-size))))) + +(defun sanity-check-change-functions-before (beg end) + (sanity-check--message "Before: %S %S" beg end) + (unless (<= (point-min) beg end (point-max)) + (sanity-check-change-functions-error + "Position bounds: %S <= %S <= %S <= %S" + (point-min) beg end (point-max))) + (sanity-check-change-functions-check-size) + (setq sanity-check-change-functions-beg beg) + (setq sanity-check-change-functions-end end)) + +(defun sanity-check-change-functions-after (beg end len) + (sanity-check--message "After : %S %S (%S)" beg end len) + (unless (<= (point-min) beg end (point-max)) + (sanity-check-change-functions-error + "Position bounds: %S <= %S <= %S <= %S" + (point-min) beg end (point-max))) + (unless (>= len 0) + (sanity-check-change-functions-error "len: %S >= 0" len)) + (let ((bend (+ beg len))) + (unless (<= sanity-check-change-functions-beg + beg bend + sanity-check-change-functions-end) + (sanity-check-change-functions-error + "After covered by before: %S <= %S <= %S <= %S" + sanity-check-change-functions-beg beg bend + sanity-check-change-functions-end))) + (let ((offset (- end beg len))) + (setq sanity-check-change-functions-end + (+ sanity-check-change-functions-end offset)) + (setq sanity-check-change-functions-buffer-size + (+ sanity-check-change-functions-buffer-size offset))) + (sanity-check-change-functions-check-size)) + +(defun sanity-check-change-functions-errors () + (sanity-check-change-functions-check-size) + (if sanity-check-change-functions-errors + (cons sanity-check-change-functions-op + sanity-check-change-functions-errors))) + +(ert-deftest editfns-tests--before/after-change-functions () + (with-temp-buffer + (add-hook 'before-change-functions + #'sanity-check-change-functions-before nil t) + (add-hook 'after-change-functions + #'sanity-check-change-functions-after nil t) + + ;; Bug#65451 + (sanity-check-change-functions-with-op 'DABBREV-EXPAND + (insert "utf-8-unix\n\nUTF") + (call-interactively 'dabbrev-expand) + (should (null (sanity-check-change-functions-errors)))) + + (let ((beg (point))) + (sanity-check-change-functions-with-op 'ENCODE-CODING-REGION + (insert "ééé") + (encode-coding-region beg (point) 'utf-8) + (should (null (sanity-check-change-functions-errors)))) + + (sanity-check-change-functions-with-op 'DECODE-CODING-REGION + (decode-coding-region beg (point) 'utf-8) + (should (null (sanity-check-change-functions-errors))))) + + (sanity-check-change-functions-with-op 'ENCODE-CODING-STRING + (encode-coding-string "ééé" 'utf-8 nil (current-buffer)) + (should (null (sanity-check-change-functions-errors)))) + + (sanity-check-change-functions-with-op 'DECODE-CODING-STRING + (decode-coding-string "\303\251\303\251\303\251" + 'utf-8 nil (current-buffer)) + (should (null (sanity-check-change-functions-errors)))))) + ;;; editfns-tests.el ends here diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 1b13785a9fc..ca5b10db705 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -418,6 +418,27 @@ (should-not (and (> size 0) (eq res seq))) (should (equal seq input)))))))))))) +(ert-deftest fns-tests-sort-gc () + ;; Make sure our temporary storage is traversed by the GC. + (let* ((n 1000) + (a (mapcar #'number-to-string (number-sequence 1 n))) + (i 0) + ;; Force frequent GCs in both the :key and :lessp functions. + (s (sort a + :key (lambda (x) + (setq i (1+ i)) + (when (> i 300) + (garbage-collect) + (setq i 0)) + (copy-sequence x)) + :lessp (lambda (a b) + (setq i (1+ i)) + (when (> i 300) + (garbage-collect) + (setq i 0)) + (string< a b))))) + (should (equal (length s) (length a))))) + (defvar w32-collate-ignore-punctuation) (ert-deftest fns-tests-collate-sort () @@ -1593,6 +1614,12 @@ ;; strings ("" . "a") ("a" . "b") ("A" . "a") ("abc" . "abd") ("b" . "ba") + ;; strings again, but in a context where 3-way comparison + ;; matters + (("" . 2) . ("a" . 1)) + (("å" . 2) . ("åü" . 1)) + (("a" . 2) . ("aå" . 1)) + (("\x80" . 2) . ("\x80å" . 1)) ;; lists ((1 2 3) . (2 3 4)) ((2) . (2 1)) (() . (0)) diff --git a/test/src/json-tests.el b/test/src/json-tests.el index dffc6291ca1..ebac70fb1c7 100644 --- a/test/src/json-tests.el +++ b/test/src/json-tests.el @@ -25,35 +25,50 @@ (require 'cl-lib) (require 'map) - -(declare-function json-serialize "json.c" (object &rest args)) -(declare-function json-insert "json.c" (object &rest args)) -(declare-function json-parse-string "json.c" (string &rest args)) -(declare-function json-parse-buffer "json.c" (&rest args)) +(require 'subr-x) (define-error 'json-tests--error "JSON test error") (ert-deftest json-serialize/roundtrip () - (skip-unless (fboundp 'json-serialize)) ;; The noncharacter U+FFFF should be passed through, ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters. - (let ((lisp [:null :false t 0 123 -456 3.75 "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"]) - (json "[null,false,true,0,123,-456,3.75,\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"]")) - (should (equal (json-serialize lisp) json)) + (let* ((lisp [:null :false t 0 123 -456 3.75 "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"]) + (json + "[null,false,true,0,123,-456,3.75,\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"]") + (json-bytes (encode-coding-string json 'utf-8))) + (should (equal (json-serialize lisp) json)) ; or `json-bytes'? (with-temp-buffer + ;; multibyte buffer (json-insert lisp) (should (equal (buffer-string) json)) + (should (equal (point) (1+ (length json)))) + (should (eobp))) + (with-temp-buffer + ;; unibyte buffer + (set-buffer-multibyte nil) + (json-insert lisp) + (should (equal (buffer-string) json-bytes)) + (should (equal (point) (1+ (length json-bytes)))) (should (eobp))) (should (equal (json-parse-string json) lisp)) (with-temp-buffer + ;; multibyte buffer (insert json) (goto-char 1) (should (equal (json-parse-buffer) lisp)) + (should (equal (point) (1+ (length json)))) + (should (eobp))) + (with-temp-buffer + ;; unibyte buffer + (set-buffer-multibyte nil) + (insert json-bytes) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (equal (point) (1+ (length json-bytes)))) (should (eobp))))) (ert-deftest json-serialize/roundtrip-scalars () "Check that Bug#42994 is fixed." - (skip-unless (fboundp 'json-serialize)) (dolist (case '((:null "null") (:false "false") (t "true") @@ -72,15 +87,25 @@ (json-insert lisp) (should (equal (buffer-string) json)) (should (eobp))) + (with-temp-buffer + (set-buffer-multibyte nil) + (json-insert lisp) + (should (equal (buffer-string) (encode-coding-string json 'utf-8))) + (should (eobp))) (should (equal (json-parse-string json) lisp)) (with-temp-buffer (insert json) (goto-char 1) (should (equal (json-parse-buffer) lisp)) + (should (eobp))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert (encode-coding-string json 'utf-8)) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) (should (eobp))))))) (ert-deftest json-serialize/object () - (skip-unless (fboundp 'json-serialize)) (let ((table (make-hash-table :test #'equal))) (puthash "abc" [1 2 t] table) (puthash "def" :null table) @@ -125,15 +150,39 @@ }"))) (ert-deftest json-serialize/object-with-duplicate-keys () - (skip-unless (fboundp 'json-serialize)) - (let ((table (make-hash-table :test #'eq))) - (puthash (copy-sequence "abc") [1 2 t] table) - (puthash (copy-sequence "abc") :null table) - (should (equal (hash-table-count table) 2)) - (should-error (json-serialize table) :type 'wrong-type-argument))) + (dolist (n '(1 5 20 100)) + (let ((symbols (mapcar (lambda (i) (make-symbol (format "s%d" i))) + (number-sequence 1 n))) + (expected (concat "{" + (mapconcat (lambda (i) (format "\"s%d\":%d" i i)) + (number-sequence 1 n) ",") + "}"))) + ;; alist + (should (equal (json-serialize + (append + (cl-mapcar #'cons + symbols (number-sequence 1 n)) + (cl-mapcar #'cons + symbols (number-sequence 1001 (+ 1000 n))))) + expected)) + ;; plist + (should (equal (json-serialize + (append + (cl-mapcan #'list + symbols (number-sequence 1 n)) + (cl-mapcan #'list + symbols (number-sequence 1001 (+ 1000 n))))) + expected)))) + + ;; We don't check for duplicated keys in hash tables. + ;; (let ((table (make-hash-table :test #'eq))) + ;; (puthash (copy-sequence "abc") [1 2 t] table) + ;; (puthash (copy-sequence "abc") :null table) + ;; (should (equal (hash-table-count table) 2)) + ;; (should-error (json-serialize table) :type 'wrong-type-argument)) + ) (ert-deftest json-parse-string/object () - (skip-unless (fboundp 'json-parse-string)) (let ((input "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")) (let ((actual (json-parse-string input))) @@ -142,12 +191,20 @@ (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) '(("abc" . [9 :false]) ("def" . :null))))) (should (equal (json-parse-string input :object-type 'alist) - '((abc . [9 :false]) (def . :null)))) + '((abc . [1 2 t]) (def . :null) (abc . [9 :false])))) (should (equal (json-parse-string input :object-type 'plist) - '(:abc [9 :false] :def :null))))) + '(:abc [1 2 t] :def :null :abc [9 :false]))))) + +(ert-deftest json-parse-string/object-unicode-keys () + (let ((input "{\"é\":1,\"☃\":2,\"𐌐\":3}")) + (let ((actual (json-parse-string input))) + (should (equal (sort (hash-table-keys actual)) '("é" "☃" "𐌐")))) + (should (equal (json-parse-string input :object-type 'alist) + '((é . 1) (☃ . 2) (𐌐 . 3)))) + (should (equal (json-parse-string input :object-type 'plist) + '(:é 1 :☃ 2 :𐌐 3))))) (ert-deftest json-parse-string/array () - (skip-unless (fboundp 'json-parse-string)) (let ((input "[\"a\", 1, [\"b\", 2]]")) (should (equal (json-parse-string input) ["a" 1 ["b" 2]])) @@ -155,7 +212,6 @@ '("a" 1 ("b" 2)))))) (ert-deftest json-parse-string/string () - (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) @@ -163,31 +219,40 @@ ["\nasdфывfgh\t"])) (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) (should-error (json-parse-string "foo") :type 'json-parse-error) - ;; FIXME: Is this the right behavior? - (should (equal (json-parse-string "[\"\u00C4\xC3\x84\"]") ["\u00C4\u00C4"]))) + (should-error (json-parse-string "[\"\u00C4\xC3\x84\"]") + :type 'json-utf8-decode-error)) (ert-deftest json-serialize/string () - (skip-unless (fboundp 'json-serialize)) (should (equal (json-serialize ["foo"]) "[\"foo\"]")) (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]")) (should (equal (json-serialize ["a\0b"]) "[\"a\\u0000b\"]")) - ;; FIXME: Is this the right behavior? - (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]"))) + (should-error (json-serialize ["\xC3\x84"])) + (should-error (json-serialize ["\u00C4\xC3\x84"]))) (ert-deftest json-serialize/invalid-unicode () - (skip-unless (fboundp 'json-serialize)) (should-error (json-serialize ["a\uDBBBb"]) :type 'wrong-type-argument) (should-error (json-serialize ["u\x110000v"]) :type 'wrong-type-argument) (should-error (json-serialize ["u\x3FFFFFv"]) :type 'wrong-type-argument) (should-error (json-serialize ["u\xCCv"]) :type 'wrong-type-argument) (should-error (json-serialize ["u\u00C4\xCCv"]) :type 'wrong-type-argument)) +(ert-deftest json-parse-string/short () + (should-error (json-parse-string "") :type 'json-end-of-file) + (should-error (json-parse-string " ") :type 'json-end-of-file) + (dolist (s '("a" "ab" "abc" "abcd" "\0" "\1" + "t" "tr" "tru" "truE" "truee" + "n" "nu" "nul" "nulL" "nulll" + "f" "fa" "fal" "fals" "falsE" "falsee")) + (condition-case err + (json-parse-string s) + (error + (should (eq (car err) 'json-parse-error))) + (:success (error "parsing %S should fail" s))))) + (ert-deftest json-parse-string/null () - (skip-unless (fboundp 'json-parse-string)) - (should-error (json-parse-string "\x00") :type 'wrong-type-argument) - (should (json-parse-string "[\"a\\u0000b\"]")) + (should (equal (json-parse-string "[\"a\\u0000b\"]") ["a\0b"])) (let* ((string "{\"foo\":\"this is a string including a literal \\u0000\"}") (data (json-parse-string string))) (should (hash-table-p data)) @@ -197,43 +262,43 @@ "Some examples from https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. Test with both unibyte and multibyte strings." - (skip-unless (fboundp 'json-parse-string)) ;; Invalid UTF-8 code unit sequences. - (should-error (json-parse-string "[\"\x80\"]") :type 'json-parse-error) - (should-error (json-parse-string "[\"\u00C4\x80\"]") :type 'json-parse-error) - (should-error (json-parse-string "[\"\xBF\"]") :type 'json-parse-error) - (should-error (json-parse-string "[\"\u00C4\xBF\"]") :type 'json-parse-error) - (should-error (json-parse-string "[\"\xFE\"]") :type 'json-parse-error) - (should-error (json-parse-string "[\"\u00C4\xFE\"]") :type 'json-parse-error) - (should-error (json-parse-string "[\"\xC0\xAF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\x80\"]") :type 'json-utf8-decode-error) + (should-error (json-parse-string "[\"\u00C4\x80\"]") + :type 'json-utf8-decode-error) + (should-error (json-parse-string "[\"\xBF\"]") :type 'json-utf8-decode-error) + (should-error (json-parse-string "[\"\u00C4\xBF\"]") + :type 'json-utf8-decode-error) + (should-error (json-parse-string "[\"\xFE\"]") :type 'json-utf8-decode-error) + (should-error (json-parse-string "[\"\u00C4\xFE\"]") + :type 'json-utf8-decode-error) + (should-error (json-parse-string "[\"\xC0\xAF\"]") + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\u00C4\xC0\xAF\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\u00C4\xC0\x80\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) ;; Surrogates. (should-error (json-parse-string "[\"\uDB7F\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\xED\xAD\xBF\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\uDB7F\uDFFF\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\xED\xAD\xBF\xED\xBF\xBF\"]") - :type 'json-parse-error) + :type 'json-utf8-decode-error) (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\xED\xBF\xBF\"]") - :type 'json-parse-error)) + :type 'json-utf8-decode-error)) (ert-deftest json-parse-string/incomplete () - (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string "[123") :type 'json-end-of-file)) (ert-deftest json-parse-string/trailing () - (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) (ert-deftest json-parse-buffer/incomplete () - (skip-unless (fboundp 'json-parse-buffer)) (with-temp-buffer (insert "[123") (goto-char 1) @@ -241,7 +306,6 @@ Test with both unibyte and multibyte strings." (should (bobp)))) (ert-deftest json-parse-buffer/trailing () - (skip-unless (fboundp 'json-parse-buffer)) (with-temp-buffer (insert "[123] [456]") (goto-char 1) @@ -250,8 +314,6 @@ Test with both unibyte and multibyte strings." (should (looking-at-p (rx " [456]" eos))))) (ert-deftest json-parse-with-custom-null-and-false-objects () - (skip-unless (and (fboundp 'json-serialize) - (fboundp 'json-parse-string))) (let* ((input "{ \"abc\" : [9, false] , \"def\" : null }") (output @@ -289,7 +351,6 @@ Test with both unibyte and multibyte strings." (should-error (json-serialize '() :object-type 'alist)))) (ert-deftest json-insert/signal () - (skip-unless (fboundp 'json-insert)) (with-temp-buffer (let ((calls 0)) (add-hook 'after-change-functions @@ -304,7 +365,6 @@ Test with both unibyte and multibyte strings." (should (equal calls 1))))) (ert-deftest json-insert/throw () - (skip-unless (fboundp 'json-insert)) (with-temp-buffer (let ((calls 0)) (add-hook 'after-change-functions @@ -320,7 +380,6 @@ Test with both unibyte and multibyte strings." (should (equal calls 1))))) (ert-deftest json-serialize/bignum () - (skip-unless (fboundp 'json-serialize)) (should (equal (json-serialize (vector (1+ most-positive-fixnum) (1- most-negative-fixnum))) (format "[%d,%d]" @@ -329,12 +388,10 @@ Test with both unibyte and multibyte strings." (ert-deftest json-parse-string/wrong-type () "Check that Bug#42113 is fixed." - (skip-unless (fboundp 'json-parse-string)) (should-error (json-parse-string 1) :type 'wrong-type-argument)) (ert-deftest json-serialize/wrong-hash-key-type () "Check that Bug#42113 is fixed." - (skip-unless (fboundp 'json-serialize)) (let ((table (make-hash-table :test #'eq))) (puthash 1 2 table) (should-error (json-serialize table) :type 'wrong-type-argument))) diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 4d7f8b71838..cc17f7eb3fa 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -174,6 +174,17 @@ literals (Bug#20852)." (load "somelib" nil t) (should (string-suffix-p "/somelib.el" (caar load-history))))) +(ert-deftest lread-test-bug70702 () + "Test for certain wholesome error messages from `read'." + (setq eval-expression-debug-on-error nil) + (setq ert-debug-on-error nil) + (with-temp-buffer + (goto-char (point-min)) + (insert "#<symbol lambda at 10>") + (goto-char (point-min)) + (should (equal (should-error (read (current-buffer))) + '(invalid-read-syntax "#<" 1 2))))) + (ert-deftest lread-lread--substitute-object-in-subtree () (let ((x (cons 0 1))) (setcar x x) diff --git a/test/src/search-tests.el b/test/src/search-tests.el index bab503f36bf..87d2f5bfa05 100644 --- a/test/src/search-tests.el +++ b/test/src/search-tests.el @@ -21,23 +21,25 @@ (require 'ert) -(ert-deftest test-replace-match-modification-hooks () - (let ((ov-set nil)) - (with-temp-buffer - (insert "1 abc") - (setq ov-set (make-overlay 3 5)) - (overlay-put - ov-set 'modification-hooks - (list (lambda (_o after &rest _args) - (when after - (let ((inhibit-modification-hooks t)) - (save-excursion - (goto-char 2) - (insert "234"))))))) - (goto-char 3) - (if (search-forward "bc") - (replace-match "bcd")) - (should (= (point) 10))))) +;; This test was bad: modification hooks should never modify +;; the buffer text, because it causes problems in too many places. +;;(ert-deftest test-replace-match-modification-hooks () ;bug#42424 +;; (let ((ov-set nil)) +;; (with-temp-buffer +;; (insert "1 abc") +;; (setq ov-set (make-overlay 3 5)) +;; (overlay-put +;; ov-set 'modification-hooks +;; (list (lambda (_o after &rest _args) +;; (when after +;; (let ((inhibit-modification-hooks t)) +;; (save-excursion +;; (goto-char 2) +;; (insert "234"))))))) +;; (goto-char 3) +;; (if (search-forward "bc") +;; (replace-match "bcd")) +;; (should (= (point) 10))))) (ert-deftest search-test--replace-match-update-data () (with-temp-buffer diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index d728b539955..7c2aa13bb34 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -68,5 +68,56 @@ (should (and (equal-including-properties (pop stack) string) (null stack))))) +(ert-deftest textprop-interval-immutability () + "Test modification of text with properties affecting mutability." + (let ((template (concat + (propertize "12345" 'inhibit-read-only t) ; 1-5 + (propertize "67890" 'read-only 'abcdefg) ; 6-10 + (propertize "ABCDE" 'inhibit-read-only t) ; 11-15 + (propertize "FGHIJ" 'inhibit-read-only 'yes) ; 16-20 + "KLMNO" ; 21-25 + (propertize "PQRST" 'inhibit-read-only 't) ; 26-30 + (propertize "UVWXYZ" 'read-only 'not-suppressed))) + inhibit-read-only) + (with-temp-buffer + (insert template) + (setq buffer-read-only t) + ;; Delete an entire inhibit-read-only region. + (progn (should (equal (delete-and-extract-region 1 6) + "12345")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + ;; Delete multiple characters inside an inhibit-read-only section. + (progn (should (equal (delete-and-extract-region 2 5) + "234")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + ;; Attempt to delete characters across both an inhibit-read-only + ;; and a read only region. + (setq buffer-read-only nil) + (should-error (delete-and-extract-region 4 7)) + (setq inhibit-read-only '(abcdefg)) + ;; Attempt the same, but with the read-only property of the second + ;; section suppressed. + (progn (should (equal (delete-and-extract-region 4 7) "456")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + (setq buffer-read-only t) + ;; Delete text across the suppressed read-only region and two + ;; other inhibit-read-only regions each with distinct intervals. + (progn (should (equal (delete-and-extract-region 7 17) + "7890ABCDEF")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + (setq inhibit-read-only nil) + ;; Attempt to delete text spanning two inhibit-read-only sections + ;; separated by immutable text. + (should-error (delete-and-extract-region 17 27)) + (setq inhibit-read-only '(abcdefg)) + ;; Attempt to delete text from the start of an inhibit-read-only + ;; section extending into protected text exempt from + ;; `inhibit-read-only''s influence towards the end of the buffer. + (should-error (delete-and-extract-region 26 37))))) + (provide 'textprop-tests) ;;; textprop-tests.el ends here diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el index bdc9630c783..5d0c92ae8a6 100644 --- a/test/src/treesit-tests.el +++ b/test/src/treesit-tests.el @@ -927,7 +927,7 @@ starting marker position, and the rest are marker positions the corresponding navigation should stop at (after running `treesit-defun-skipper'). -TACTIC is the same as in `treesit--navigate-thing'. +TACTIC is the same as in `treesit-navigate-thing'. OPENING and CLOSING are the same as in `treesit--ert-insert-and-parse-marker', by default they are \"[\" @@ -939,7 +939,7 @@ and \"]\"." (closing (or closing "]")) ;; Insert program and parse marker positions. (marker-alist (treesit--ert-insert-and-parse-marker - opening closing program)) + opening closing program)) ;; Translate marker positions into buffer positions. (decoded-master (cl-loop for record in master @@ -955,7 +955,7 @@ and \"]\"." (mapcar (lambda (conf) (lambda () (if-let ((pos (funcall - #'treesit--navigate-thing + #'treesit-navigate-thing (point) (car conf) (cdr conf) treesit-defun-type-regexp tactic))) (save-excursion |
