diff --git a/.gitignore b/.gitignore index e32425abeab..25ed3bdddd3 100644 --- a/.gitignore +++ b/.gitignore @@ -182,6 +182,7 @@ ID # Executables. *.exe a.out +lib-src/be-resources lib-src/blessmail lib-src/ctags lib-src/ebrowse @@ -203,6 +204,7 @@ nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist src/bootstrap-emacs src/emacs src/emacs-[0-9]* +src/Emacs src/temacs src/dmpstruct.h src/*.pdmp diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3138f4184e6..402c17ddb85 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -15,7 +15,7 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see . -# GNU Emacs support for the GitLab protocol for CI +# GNU Emacs support for the GitLab protocol for CI. # The presence of this file does not imply any FSF/GNU endorsement of # any particular service that uses that protocol. Also, it is intended for diff --git a/CONTRIBUTE b/CONTRIBUTE index 8295a8e6ad4..5740004637b 100644 --- a/CONTRIBUTE +++ b/CONTRIBUTE @@ -342,7 +342,9 @@ Documentation fixes (in doc strings, in manuals, in NEWS, and in comments) should always go to the release branch, if the documentation to be fixed exists and is relevant to the release-branch codebase. Doc fixes are always considered "safe" -- even when a release branch -is in feature freeze, it can still receive doc fixes. +is in feature freeze, it can still receive doc fixes. However, this +rule is limited to fixing real problems in the documentation; cleanups +and stylistic changes are excluded. When you know that the change will be difficult to merge to the master (e.g., because the code on master has changed a lot), you can diff --git a/GNUmakefile b/GNUmakefile index 5155487de28..76fd77ba1b0 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -104,8 +104,13 @@ configure: Makefile: configure @echo >&2 'There seems to be no Makefile in this directory.' +ifeq ($(configure),default) @echo >&2 'Running ./configure ...' ./configure +else + @echo >&2 'Running ./configure '$(configure)'...' + ./configure $(configure) +endif @echo >&2 'Makefile built.' # 'make bootstrap' in a fresh checkout needn't run 'configure' twice. diff --git a/INSTALL.REPO b/INSTALL.REPO index da56d7611b2..182c2e95341 100644 --- a/INSTALL.REPO +++ b/INSTALL.REPO @@ -8,9 +8,15 @@ directory on your local machine: To build the repository code, simply run 'make' in the 'emacs' directory. This should work if your files are freshly checked out -from the repository, and if you have the proper tools installed. If -it doesn't work, or if you have special build requirements, the -following information may be helpful. +from the repository, and if you have the proper tools installed; the +default configuration options will be used. Other configuration +options can be specified by setting a 'configure' variable, for +example: + + $ make configure="--prefix=/opt/emacs CFLAGS='-O0 -g3'" + +If the above doesn't work, or if you have special build requirements, +the following information may be helpful. Building Emacs from the source-code repository requires some tools that are not needed when building from a release. You will need: @@ -58,7 +64,16 @@ To update loaddefs.el (and similar files), do: If either of the above partial procedures fails, try 'make bootstrap'. If CPU time is not an issue, 'make bootstrap' is a more thorough way -to rebuild, avoiding spurious problems. +to rebuild, avoiding spurious problems. 'make bootstrap' rebuilds +Emacs with the same configuration options as the previous build; it +can also be used to rebuild Emacs with other configuration options by +setting a 'configure' variable, for example: + + $ make bootstrap configure="CFLAGS='-O0 -g3'" + +To rebuild Emacs with the default configuration options, you can use: + + $ make bootstrap configure=default Occasionally, there are changes that 'make bootstrap' won't be able to handle. The most thorough cleaning can be achieved by 'git clean -fdx' diff --git a/Makefile.in b/Makefile.in index 488b859285d..59b255b9267 100644 --- a/Makefile.in +++ b/Makefile.in @@ -102,6 +102,8 @@ HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ USE_STARTUP_NOTIFICATION = @USE_STARTUP_NOTIFICATION@ +HAVE_BE_APP = @HAVE_BE_APP@ + # ==================== Where To Install Things ==================== # Location to install Emacs.app under GNUstep / macOS. @@ -528,7 +530,13 @@ install-arch-dep: src install-arch-indep install-etcdoc install-$(NTDIR) $(MAKE) -C lib-src install ifeq (${ns_self_contained},no) ${INSTALL_PROGRAM} $(INSTALL_STRIP) src/emacs${EXEEXT} "$(DESTDIR)${bindir}/$(EMACSFULL)" +ifeq (${HAVE_BE_APP},yes) + ${INSTALL_PROGRAM} $(INSTALL_STRIP) src/Emacs "$(DESTDIR)${prefix}/apps/Emacs" +endif ifeq (${DUMPING},pdumper) +ifeq (${HAVE_BE_APP},yes) + ${INSTALL_DATA} src/Emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/Emacs.pdmp +endif ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs-${EMACS_PDMP} endif -chmod 755 "$(DESTDIR)${bindir}/$(EMACSFULL)" @@ -1144,14 +1152,23 @@ check-info: info .PHONY: bootstrap -# Bootstrapping does the following: +# Without a 'configure' variable, bootstrapping does the following: # * Remove files to start from a bootstrap-clean slate. # * Run autogen.sh. # * Rebuild Makefile, to update the build procedure itself. # * Do the actual build. -bootstrap: bootstrap-clean +# With a 'configure' variable, bootstrapping does the following: +# * Remove files to start from an extraclean slate. +# * Do the actual build, during which the 'configure' variable is +# used (see the Makefile goal in GNUmakefile). +bootstrap: +ifndef configure + $(MAKE) bootstrap-clean cd $(srcdir) && ./autogen.sh autoconf $(MAKE) MAKEFILE_NAME=force-Makefile force-Makefile +else + $(MAKE) extraclean +endif $(MAKE) all .PHONY: ChangeLog change-history change-history-commit change-history-nocommit diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index 02b8cf39bd6..33aeb528651 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -138,6 +138,9 @@ Andrea Corallo lisp/emacs-lisp/comp-cstr.el test/src/comp-*.el +Stefan Kangas + admin/automerge + ============================================================================== 2. Areas that someone is willing to maintain, although he would not necessarily mind if someone else was the official maintainer. @@ -228,6 +231,7 @@ Michael Albinus lisp/net/ange-ftp.el lisp/notifications.el lisp/shadowfile.el + test/infra/* test/lisp/autorevert-tests.el test/lisp/files-tests.el (file-name-non-special) test/lisp/shadowfile-tests.el diff --git a/admin/authors.el b/admin/authors.el index fd46dabaa3a..1e8bf0364d6 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -323,7 +323,8 @@ Changes to files matching one of the regexps in this list are not listed.") "NEWS.unicode" "COPYING.DJ" "Makefile.old" "Makefile.am" "NEWS.1" "OOOOONEWS...OONEWS" "OOOONEWS" "etc/NEWS" "NEWS.1-17" "NEWS.18" "NEWS.19" "NEWS.20" "NEWS.21" "NEWS.22" - "MAINTAINERS" "MH-E-NEWS" + "NEWS.23" "NEWS.24" "NEWS.25" "NEWS.26" "NEWS.27" "NEWS.28" + "MAINTAINERS" "ERC-NEWS" "MH-E-NEWS" "NXML-NEWS" "install.sh" "install-sh" "missing" "mkinstalldirs" "termcap.dat" "termcap.src" "termcap.ucb" "termcap" "ChangeLog.nextstep" "Emacs.clr" "spec.txt" @@ -359,6 +360,8 @@ Changes to files matching one of the regexps in this list are not listed.") "autogen/missing" "autogen" "autogen/copy_autogen" ; not generated, but trivial and now removed "dir_top" + ;; Imported into Emacs but externally maintained. + "publicsuffix.txt" "SKK-JISYO.L" ;; Only existed briefly, then renamed: "images/icons/allout-widgets-dark-bg" "images/icons/allout-widgets-light-bg" diff --git a/admin/automerge b/admin/automerge index 227a404b7a3..81082f7dc68 100755 --- a/admin/automerge +++ b/admin/automerge @@ -4,7 +4,7 @@ ## Copyright (C) 2018-2021 Free Software Foundation, Inc. ## Author: Glenn Morris -## Maintainer: emacs-devel@gnu.org +## Maintainer: Stefan Kangas ## This file is part of GNU Emacs. diff --git a/admin/gitmerge.el b/admin/gitmerge.el index 67fca87c119..658ceb77f49 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -68,8 +68,7 @@ bump Emacs version\\|Auto-commit")) (defvar gitmerge-minimum-missing 10 "Minimum number of missing commits to consider merging in batch mode.") -(defvar gitmerge-status-file (expand-file-name "gitmerge-status" - user-emacs-directory) +(defvar gitmerge-status-file (locate-user-emacs-file "gitmerge-status") "File where missing commits will be saved between sessions.") (defvar gitmerge-ignore-branches-regexp diff --git a/admin/notes/emba b/admin/notes/emba index 4e500bc92cf..f1b52b2cde0 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -28,15 +28,21 @@ The messages contain a URL to the log file of the failed job, like * Emacs jobset The Emacs jobset is defined in the Emacs source tree, file -'.gitlab-ci.yml'. It could be adapted for every Emacs branch, see +'.gitlab-ci.yml'. All related files are located in directory +'test/infra'. They could be adapted for every Emacs branch, see . A jobset on Gitlab is called pipeline. Emacs pipelines run through the stages 'build-images', 'platform-images' and 'native-comp-images' (create an Emacs instance by 'make bootstrap' with different -configuration parameters) as well as 'normal', 'slow', 'platforms' and +configuration parameters) as well as 'normal', 'platforms' and 'native-comp' (run respective test jobs based on the produced images). +The jobs for stage 'normal' are contained in the file +'test/infra/test-jobs.yml'. This file is generated by calling 'make +-C test generate-test-jobs' in the Emacs source tree, and the +resulting file shall be pushed to the Emacs git repository afterwards. + Every job runs in a Debian docker container. It uses the local clone of the Emacs git repository to perform a bootstrap and test of Emacs. This could happen for several jobs with changed configuration, compile diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index 6bed191cae7..dfff493b640 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -123,7 +123,7 @@ def ntldd_munge(out): ## Currently no packages seem to require this! ARCH_PKGS=[] -SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources" +SRC_REPO="https://repo.msys2.org/mingw/sources" def immediate_deps(pkgs): @@ -169,7 +169,7 @@ def download_source(tarball): if not os.path.exists("../emacs-src-cache/{}".format(tarball)): print("Downloading {}...".format(tarball)) check_output_maybe( - "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}/download" + "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}" .format(tarball, SRC_REPO, tarball), shell=True ) diff --git a/admin/unidata/emoji-zwj.awk b/admin/unidata/emoji-zwj.awk index d4e2944ca34..e704cb45263 100644 --- a/admin/unidata/emoji-zwj.awk +++ b/admin/unidata/emoji-zwj.awk @@ -114,7 +114,7 @@ END { print " (nconc (char-table-range composition-function-table (car elt))" print " (list (vector (cdr elt)" print " 0" - print " 'compose-gstring-for-graphic)))))" + print " #'compose-gstring-for-graphic)))))" print ";; The following two blocks are derived by hand from emoji-sequences.txt" print ";; FIXME: add support for Emoji_Keycap_Sequence once we learn how to respect FE0F/VS-16" @@ -126,7 +126,7 @@ END { print " (nconc (char-table-range composition-function-table '(#x1F1E6 . #x1F1FF))" print " (list (vector \"[\\U0001F1E6-\\U0001F1FF][\\U0001F1E6-\\U0001F1FF]\"" print " 0" - print " 'compose-gstring-for-graphic))))" + print " #'compose-gstring-for-graphic))))" print ";; UK Flags" print "(set-char-table-range composition-function-table" @@ -134,7 +134,7 @@ END { print " (nconc (char-table-range composition-function-table #x1F3F4)" print " (list (vector \"\\U0001F3F4\\U000E0067\\U000E0062\\\\(?:\\U000E0065\\U000E006E\\U000E0067\\\\|\\U000E0073\\U000E0063\\U000E0074\\\\|\\U000E0077\\U000E006C\\U000E0073\\\\)\\U000E007F\"" print " 0" - print " 'compose-gstring-for-graphic))))" + print " #'compose-gstring-for-graphic))))" printf "\n(provide 'emoji-zwj)" } diff --git a/configure.ac b/configure.ac index d68cf42145a..fffac4c2e61 100644 --- a/configure.ac +++ b/configure.ac @@ -488,6 +488,7 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support]) OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin]) +OPTION_DEFAULT_OFF([xinput2],[use version 2 of the X Input Extension for input]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -511,6 +512,12 @@ otherwise for the first of 'inotify', 'kqueue' or 'gfile' that is usable.]) OPTION_DEFAULT_OFF([xwidgets], [enable use of xwidgets in Emacs buffers (requires gtk3 or macOS Cocoa)]) +OPTION_DEFAULT_OFF([be-app], + [enable use of Haiku's Application Kit as a window system]) + +OPTION_DEFAULT_OFF([be-cairo], + [enable use of cairo under Haiku's Application Kit]) + ## Makefile.in needs the cache file name. AC_SUBST(cache_file) @@ -787,6 +794,10 @@ case "${canonical}" in LDFLAGS="-N2M $LDFLAGS" ;; + *-haiku ) + opsys=haiku + ;; + ## Intel 386 machines where we don't care about the manufacturer. i[3456]86-*-* ) case "${canonical}" in @@ -908,7 +919,9 @@ if test "$ac_test_CFLAGS" != set; then if test $emacs_cv_prog_cc_g3 != yes; then CFLAGS=$emacs_save_CFLAGS fi - if test $opsys = mingw32; then + # Haiku also needs -gdwarf-2 because its GDB is too old + # to understand newer formats. + if test $opsys = mingw32 || test $opsys = haiku; then CFLAGS="$CFLAGS -gdwarf-2" fi fi @@ -1575,6 +1588,8 @@ case "$opsys" in ## Motif needs -lgen. unixware) LIBS_SYSTEM="-lsocket -lnsl -lelf -lgen" ;; + + haiku) LIBS_SYSTEM="-lnetwork" ;; esac AC_SUBST(LIBS_SYSTEM) @@ -2086,6 +2101,22 @@ if test "${HAVE_NS}" = yes; then fi fi +HAVE_BE_APP=no +if test "${opsys}" = "haiku" && test "${with_be_app}" = "yes"; then + dnl Only GCC is supported. Clang might work, but it's + dnl not reliable, so don't check for it here. + AC_PROG_CXX([gcc g++]) + CXXFLAGS="$CXXFLAGS $emacs_g3_CFLAGS" + AC_LANG_PUSH([C++]) + AC_CHECK_HEADER([app/Application.h], [HAVE_BE_APP=yes], + [AC_MSG_ERROR([The Application Kit headers required for building +with the Application Kit were not found or cannot be compiled. Either fix this, or +re-configure with the option '--without-be-app'.])]) + AC_LANG_POP([C++]) +fi + +AC_SUBST(HAVE_BE_APP) + HAVE_W32=no W32_OBJ= W32_LIBS= @@ -2207,6 +2238,39 @@ if test "${HAVE_W32}" = "yes"; then with_xft=no fi +HAIKU_OBJ= +HAIKU_CXX_OBJ= +HAIKU_LIBS= +HAIKU_CFLAGS= + +if test "$opsys" = "haiku"; then + HAIKU_OBJ="$HAIKU_OBJ haiku.o" +fi + +if test "${HAVE_BE_APP}" = "yes"; then + AC_DEFINE([HAVE_HAIKU], 1, + [Define if Emacs will be built with Haiku windowing support]) +fi + +if test "${HAVE_BE_APP}" = "yes"; then + window_system=haiku + with_xft=no + HAIKU_OBJ="$HAIKU_OBJ haikufns.o haikuterm.o haikumenu.o haikufont.o haikuselect.o haiku_io.o" + HAIKU_CXX_OBJ="haiku_support.o haiku_font_support.o haiku_draw_support.o haiku_select.o" + HAIKU_LIBS="-lbe -lgame -ltranslation -ltracker" # -lgame is needed for set_mouse_position. + + if test "${with_native_image_api}" = yes; then + AC_DEFINE(HAVE_NATIVE_IMAGE_API, 1, [Define to use native OS APIs for images.]) + NATIVE_IMAGE_API="yes (haiku)" + HAIKU_OBJ="$HAIKU_OBJ haikuimage.o" + fi +fi + +AC_SUBST(HAIKU_LIBS) +AC_SUBST(HAIKU_OBJ) +AC_SUBST(HAIKU_CXX_OBJ) +AC_SUBST(HAIKU_CFLAGS) + ## $window_system is now set to the window system we will ## ultimately use. @@ -2251,6 +2315,9 @@ dnl use the toolkit if we have gtk, or X11R5 or newer. with_gtk3=yes USE_X_TOOLKIT=none ;; + haiku ) + term_header=haikuterm.h + ;; esac if test "$window_system" = none && test "X$with_x" != "Xno"; then @@ -2582,7 +2649,9 @@ fi ### Use -lrsvg-2 if available, unless '--with-rsvg=no' is specified. HAVE_RSVG=no -if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${window_system}" = "pgtk" || test "${opsys}" = "mingw32"; then +if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" \ + || test "${opsys}" = "mingw32" || test "${HAVE_BE_APP}" = "yes" \ + || test "${window_system}" = "pgtk"; then if test "${with_rsvg}" != "no"; then RSVG_REQUIRED=2.14.0 RSVG_MODULE="librsvg-2.0 >= $RSVG_REQUIRED" @@ -2606,7 +2675,8 @@ fi HAVE_WEBP=no if test "${with_webp}" != "no"; then if test "${HAVE_X11}" = "yes" || test "${opsys}" = "mingw32" \ - || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then + || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \ + || test "${HAVE_BE_APP}" = "yes"; then WEBP_REQUIRED=0.6.0 WEBP_MODULE="libwebp >= $WEBP_REQUIRED" @@ -2625,7 +2695,8 @@ if test "${with_webp}" != "no"; then fi HAVE_IMAGEMAGICK=no -if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${window_system}" = "pgtk" || test "${HAVE_W32}" = "yes"; then +if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes" || \ + test "${HAVE_BE_APP}" = "yes" || test "${window_system}" = "pgtk"; then if test "${with_imagemagick}" != "no"; then if test -n "$BREW"; then # Homebrew doesn't link ImageMagick 6 by default, so make sure @@ -3289,6 +3360,9 @@ if test "${with_toolkit_scroll_bars}" != "no"; then elif test "${HAVE_W32}" = "yes"; then AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) USE_TOOLKIT_SCROLL_BARS=yes + elif test "${HAVE_BE_APP}" = "yes"; then + AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) + USE_TOOLKIT_SCROLL_BARS=yes fi fi @@ -3378,6 +3452,22 @@ if test "${HAVE_X11}" = "yes"; then fi fi fi +if test "${HAVE_BE_APP}" = "yes"; then + if test "${with_be_cairo}" != "no"; then + CAIRO_REQUIRED=1.8.0 + CAIRO_MODULE="cairo >= $CAIRO_REQUIRED" + EMACS_CHECK_MODULES(CAIRO, $CAIRO_MODULE) + if test $HAVE_CAIRO = yes; then + AC_DEFINE(USE_BE_CAIRO, 1, [Define to 1 if using cairo on Haiku.]) + CFLAGS="$CFLAGS $CAIRO_CFLAGS" + LIBS="$LIBS $CAIRO_LIBS" + AC_SUBST(CAIRO_CFLAGS) + AC_SUBST(CAIRO_LIBS) + else + AC_MSG_WARN([cairo requested but not found.]) + fi + fi +fi ### Start of font-backend (under any platform) section. # (nothing here yet -- this is a placeholder) @@ -3552,6 +3642,58 @@ if test "${HAVE_X11}" = "yes" && test "${HAVE_FREETYPE}" = "yes" \ fi fi +### Start of font-backend (under Haiku) selectionn. +if test "${HAVE_BE_APP}" = "yes"; then + if test $HAVE_CAIRO = "yes"; then + EMACS_CHECK_MODULES([FREETYPE], [freetype2 >= 2.5.0]) + test "$HAVE_FREETYPE" = "no" && AC_MSG_ERROR(cairo on Haiku requires libfreetype) + EMACS_CHECK_MODULES([FONTCONFIG], [fontconfig >= 2.2.0]) + test "$HAVE_FONTCONFIG" = "no" && AC_MSG_ERROR(cairo on Haiku requires libfontconfig) + fi + + HAVE_LIBOTF=no + + if test "${HAVE_FREETYPE}" = "yes"; then + AC_DEFINE(HAVE_FREETYPE, 1, + [Define to 1 if using the freetype and fontconfig libraries.]) + OLD_CFLAGS=$CFLAGS + OLD_LIBS=$LIBS + CFLAGS="$CFLAGS $FREETYPE_CFLAGS" + LIBS="$FREETYPE_LIBS $LIBS" + AC_CHECK_FUNCS(FT_Face_GetCharVariantIndex) + CFLAGS=$OLD_CFLAGS + LIBS=$OLD_LIBS + if test "${with_libotf}" != "no"; then + EMACS_CHECK_MODULES([LIBOTF], [libotf]) + if test "$HAVE_LIBOTF" = "yes"; then + AC_DEFINE(HAVE_LIBOTF, 1, [Define to 1 if using libotf.]) + AC_CHECK_LIB(otf, OTF_get_variation_glyphs, + HAVE_OTF_GET_VARIATION_GLYPHS=yes, + HAVE_OTF_GET_VARIATION_GLYPHS=no) + if test "${HAVE_OTF_GET_VARIATION_GLYPHS}" = "yes"; then + AC_DEFINE(HAVE_OTF_GET_VARIATION_GLYPHS, 1, + [Define to 1 if libotf has OTF_get_variation_glyphs.]) + fi + if ! $PKG_CONFIG --atleast-version=0.9.16 libotf; then + AC_DEFINE(HAVE_OTF_KANNADA_BUG, 1, +[Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.]) + fi + fi + fi + dnl FIXME should there be an error if HAVE_FREETYPE != yes? + dnl Does the new font backend require it, or can it work without it? + fi +fi + +if test "${HAVE_BE_APP}" = "yes" && test "${HAVE_FREETYPE}" = "yes"; then + if test "${with_harfbuzz}" != "no"; then + EMACS_CHECK_MODULES([HARFBUZZ], [harfbuzz >= $harfbuzz_required_ver]) + if test "$HAVE_HARFBUZZ" = "yes"; then + AC_DEFINE(HAVE_HARFBUZZ, 1, [Define to 1 if using HarfBuzz.]) + fi + fi +fi + ### End of font-backend section. AC_SUBST(FREETYPE_CFLAGS) @@ -3691,8 +3833,9 @@ AC_SUBST(LIBXPM) ### Use -ljpeg if available, unless '--with-jpeg=no'. HAVE_JPEG=no LIBJPEG= -if test "${HAVE_X11}" = "yes" || test "$window_system" = "pgtk" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then +if test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ + || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \ + || test "$window_system" = "pgtk"; then if test "${with_jpeg}" != "no"; then AC_CACHE_CHECK([for jpeglib 6b or later], [emacs_cv_jpeglib], @@ -4009,8 +4152,9 @@ if test "${with_png}" != no; then # mingw32 loads the library dynamically. if test "$opsys" = mingw32; then AC_CHECK_HEADER([png.h], [HAVE_PNG=yes]) - elif test "${HAVE_X11}" = "yes" || test "$window_system" = "pgtk" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ + || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \ + || test "$window_system" = "pgtk"; then EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0]) if test $HAVE_PNG = yes; then LIBPNG=$PNG_LIBS @@ -4084,8 +4228,9 @@ if test "${opsys}" = "mingw32"; then if test "${HAVE_TIFF}" = "yes"; then AC_DEFINE(HAVE_TIFF, 1, [Define to 1 if you have the tiff library (-ltiff).]) fi -elif test "${HAVE_X11}" = "yes" || test "${window_system}" = "pgtk" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then +elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ + || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \ + || test "$window_system" = "pgtk"; then if test "${with_tiff}" != "no"; then AC_CHECK_HEADER(tiffio.h, [tifflibs="-lz -lm" @@ -4113,8 +4258,9 @@ if test "${opsys}" = "mingw32"; then if test "${HAVE_GIF}" = "yes"; then AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif (or ungif) library.]) fi -elif test "${HAVE_X11}" = "yes" -o "${window_system}" = "pgtk" && test "${with_gif}" != "no" \ - || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then +elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \ + || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \ + || test "${HAVE_BE_APP}" = "yes" || test "$window_system" = "pgtk"; then AC_CHECK_HEADER(gif_lib.h, # EGifPutExtensionLast only exists from version libungif-4.1.0b1. # Earlier versions can crash Emacs, but version 5.0 removes EGifPutExtensionLast. @@ -4307,6 +4453,26 @@ fi AC_SUBST(XFIXES_CFLAGS) AC_SUBST(XFIXES_LIBS) +## Use XInput 2.0 if available +HAVE_XINPUT2=no +if test "${HAVE_X11}" = "yes" && test "${with_xinput2}" != "no"; then + EMACS_CHECK_MODULES([XINPUT], [xi]) + if test $HAVE_XINPUT = yes; then + # Now check for XInput2.h + AC_CHECK_HEADER(X11/extensions/XInput2.h, + [AC_CHECK_LIB(Xi, XIGrabButton, HAVE_XINPUT2=yes)]) + fi + if test $HAVE_XINPUT2 = yes; then + AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 or later is present.]) + if test "$USE_GTK_TOOLKIT" = "GTK2"; then + AC_MSG_WARN([You are building Emacs with GTK+ 2 and the X Input Extension version 2. +This might lead to problems if your version of GTK+ is not built with support for XInput 2.]) + fi + fi +fi +AC_SUBST(XINPUT_CFLAGS) +AC_SUBST(XINPUT_LIBS) + ### Use Xdbe (-lXdbe) if available HAVE_XDBE=no if test "${HAVE_X11}" = "yes"; then @@ -4531,6 +4697,13 @@ case $with_unexec,$canonical in [AC_MSG_ERROR([Non-ELF systems are not supported on this platform.])]);; esac +if test "$with_unexec" = yes && test "$opsys" = "haiku"; then + dnl A serious attempt was actually made to port unexec to Haiku. + dnl Something in libstdc++ seems to prevent it from working. + AC_MSG_ERROR([Haiku is not supported by the legacy unexec dumper. +Please use the portable dumper instead.]) +fi + # Dump loading AC_CHECK_FUNCS([posix_madvise]) @@ -4884,7 +5057,7 @@ CFLAGS="$OLDCFLAGS" LIBS="$OLDLIBS"]) if test "${emacs_cv_links_glib}" = "yes"; then AC_DEFINE(HAVE_GLIB, 1, [Define to 1 if GLib is linked in.]) - if test "$HAVE_NS" = no;then + if test "$HAVE_NS" = no ; then XGSELOBJ=xgselect.o fi fi @@ -5139,7 +5312,7 @@ dnl It would have Emacs fork off a separate process dnl to read the input and send it to the true Emacs process dnl through a pipe. case $opsys in - darwin | gnu-linux | gnu-kfreebsd ) + darwin | gnu-linux | gnu-kfreebsd) AC_DEFINE(INTERRUPT_INPUT, 1, [Define to read input using SIGIO.]) ;; esac @@ -5235,6 +5408,14 @@ case $opsys in AC_DEFINE(PTY_OPEN, [fd = open (pty_name, O_RDWR | O_NONBLOCK)]) AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable slave pty"); snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }]) ;; + + haiku*) + AC_DEFINE(FIRST_PTY_LETTER, ['s']) + AC_DEFINE(PTY_NAME_SPRINTF, []) + dnl on Haiku pty names aren't distinctive, thus the use of posix_openpt + AC_DEFINE(PTY_OPEN, [fd = posix_openpt (O_RDWR | O_NONBLOCK)]) + AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable slave pty"); snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }]) + ;; esac @@ -5456,8 +5637,25 @@ case $opsys in AC_DEFINE(USG, []) AC_DEFINE(USG5_4, []) ;; + + haiku) + AC_DEFINE(HAIKU, [], [Define if the system is Haiku.]) + ;; esac +AC_SYS_POSIX_TERMIOS +if test $ac_cv_sys_posix_termios = yes; then + AC_CHECK_SIZEOF([speed_t], [], [#include ]) + dnl on Haiku, and possibly other platforms, speed_t is defined to + dnl unsigned char, even when speeds greater than 200 baud are + dnl defined. + + if test ${ac_cv_sizeof_speed_t} -lt 2; then + AC_DEFINE([HAVE_TINY_SPEED_T], [1], + [Define to 1 if speed_t has some sort of nonsensically tiny size.]) + fi +fi + AC_CACHE_CHECK([for usable FIONREAD], [emacs_cv_usable_FIONREAD], [case $opsys in aix4-2 | nacl) @@ -5500,6 +5698,22 @@ if test $emacs_cv_usable_FIONREAD = yes; then AC_DEFINE([USABLE_SIGIO], [1], [Define to 1 if SIGIO is usable.]) fi fi + + if test $emacs_broken_SIGIO = no && test $emacs_cv_usable_SIGIO = no; then + AC_CACHE_CHECK([for usable SIGPOLL], [emacs_cv_usable_SIGPOLL], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[#include + #include + ]], + [[int foo = SIGPOLL | F_SETFL;]])], + [emacs_cv_usable_SIGPOLL=yes], + [emacs_cv_usable_SIGPOLL=no])], + [emacs_cv_usable_SIGPOLL=yes], + [emacs_cv_usable_SIGPOLL=no]) + if test $emacs_cv_usable_SIGPOLL = yes; then + AC_DEFINE([USABLE_SIGPOLL], [1], [Define to 1 if SIGPOLL is usable but SIGIO is not.]) + fi + fi fi case $opsys in @@ -5616,6 +5830,17 @@ fi if test "${window_system}" = "pgtk"; then FONT_OBJ="ftfont.o ftcrfont.o" fi + +if test "${HAVE_BE_APP}" = "yes" ; then + if test "${HAVE_FREETYPE}" = "yes" || \ + test "${HAVE_CAIRO}" = "yes"; then + FONT_OBJ="$FONT_OBJ ftfont.o" + fi + if test "${HAVE_CAIRO}" = "yes"; then + FONT_OBJ="$FONT_OBJ ftcrfont.o" + fi +fi + if test "${HAVE_HARFBUZZ}" = "yes" ; then FONT_OBJ="$FONT_OBJ hbfont.o" fi @@ -6004,11 +6229,11 @@ Configured for '${canonical}'. #### Please respect alphabetical ordering when making additions. optsep= emacs_config_features= -for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \ +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 \ M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PGTK PNG RSVG SECCOMP \ SOUND THREADS TIFF TOOLKIT_SCROLL_BARS \ - UNEXEC WEBP X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \ + UNEXEC WEBP X11 XAW3D XDBE XFT XIM XINPUT2 XPM XWIDGETS X_TOOLKIT \ ZLIB; do case $opt in @@ -6085,6 +6310,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} + Does Emacs use version 2 of the the X Input Extension? ${HAVE_XINPUT2} "]) if test -n "${EMACSDATA}"; then @@ -6161,6 +6387,13 @@ if test -f "$srcdir/$opt_makefile.in"; then dnl ", [], [opt_makefile='$opt_makefile']" and it should work. AC_CONFIG_FILES([test/Makefile]) fi +opt_makefile=test/infra/Makefile +if test -f "$srcdir/$opt_makefile.in"; then + SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES $opt_makefile" + dnl Again, it's best not to use a variable. Though you can add + dnl ", [], [opt_makefile='$opt_makefile']" and it should work. + AC_CONFIG_FILES([test/infra/Makefile]) +fi dnl The admin/ directory used to be excluded from tarfiles. diff --git a/doc/emacs/Makefile.in b/doc/emacs/Makefile.in index 69d39efa8b9..dde3ae83c16 100644 --- a/doc/emacs/Makefile.in +++ b/doc/emacs/Makefile.in @@ -140,6 +140,7 @@ EMACSSOURCES= \ ${srcdir}/xresources.texi \ ${srcdir}/anti.texi \ ${srcdir}/macos.texi \ + $(srcdir)/haiku.texi \ ${srcdir}/msdos.texi \ ${srcdir}/gnu.texi \ ${srcdir}/glossary.texi \ diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index d9d6a680057..917f6f49214 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1584,7 +1584,7 @@ which overrides the global definitions of some keys. self-inserting because the global keymap binds it to the command @code{self-insert-command}. The standard Emacs editing characters such as @kbd{C-a} also get their standard meanings from the global -keymap. Commands to rebind keys, such as @kbd{M-x global-set-key}, +keymap. Commands to rebind keys, such as @kbd{M-x keymap-global-set}, work by storing the new binding in the proper place in the global map (@pxref{Rebinding}). To view the current key bindings, use the @kbd{C-h b} command. @@ -1736,8 +1736,8 @@ them, it may be convenient to disable completion on those keys by putting this in your init file: @lisp -(define-key minibuffer-local-completion-map " " 'self-insert-command) -(define-key minibuffer-local-completion-map "?" 'self-insert-command) +(keymap-set minibuffer-local-completion-map "SPC" 'self-insert-command) +(keymap-set minibuffer-local-completion-map "?" 'self-insert-command) @end lisp @node Rebinding @@ -1756,19 +1756,19 @@ local keymap, which affects all buffers using the same major mode. Emacs session. @xref{Init Rebinding}, for a description of how to make key rebindings affect future Emacs sessions. -@findex global-set-key -@findex local-set-key -@findex global-unset-key -@findex local-unset-key +@findex keymap-global-set +@findex keymap-local-set +@findex keymap-global-unset +@findex keymap-local-unset @table @kbd -@item M-x global-set-key @key{RET} @var{key} @var{cmd} @key{RET} +@item M-x keymap-global-set @key{RET} @var{key} @var{cmd} @key{RET} Define @var{key} globally to run @var{cmd}. -@item M-x local-set-key @key{RET} @var{key} @var{cmd} @key{RET} +@item M-x keymap-local-set @key{RET} @var{key} @var{cmd} @key{RET} Define @var{key} locally (in the major mode now in effect) to run @var{cmd}. -@item M-x global-unset-key @key{RET} @var{key} +@item M-x keymap-global-unset @key{RET} @var{key} Make @var{key} undefined in the global map. -@item M-x local-unset-key @key{RET} @var{key} +@item M-x keymap-local-unset @key{RET} @var{key} Make @var{key} undefined locally (in the major mode now in effect). @end table @@ -1777,11 +1777,11 @@ command (@pxref{Interactive Shell}), replacing the normal global definition of @kbd{C-z}: @example -M-x global-set-key @key{RET} C-z shell @key{RET} +M-x keymap-global-set @key{RET} C-z shell @key{RET} @end example @noindent -The @code{global-set-key} command reads the command name after the +The @code{keymap-global-set} command reads the command name after the key. After you press the key, a message like this appears so that you can confirm that you are binding the key you want: @@ -1802,7 +1802,7 @@ reads another character; if that is @kbd{4}, another prefix character, it reads one more character, and so on. For example, @example -M-x global-set-key @key{RET} C-x 4 $ spell-other-window @key{RET} +M-x keymap-global-set @key{RET} C-x 4 $ spell-other-window @key{RET} @end example @noindent @@ -1810,8 +1810,8 @@ redefines @kbd{C-x 4 $} to run the (fictitious) command @code{spell-other-window}. You can remove the global definition of a key with -@code{global-unset-key}. This makes the key @dfn{undefined}; if you -type it, Emacs will just beep. Similarly, @code{local-unset-key} makes +@code{keymap-global-unset}. This makes the key @dfn{undefined}; if you +type it, Emacs will just beep. Similarly, @code{keymap-local-unset} makes a key undefined in the current major mode keymap, which makes the global definition (or lack of one) come back into effect in that major mode. @@ -1844,11 +1844,11 @@ you can specify them in your initialization file by writing Lisp code. simplest is to use the @code{kbd} function, which converts a textual representation of a key sequence---similar to how we have written key sequences in this manual---into a form that can be passed as an -argument to @code{global-set-key}. For example, here's how to bind +argument to @code{keymap-global-set}. For example, here's how to bind @kbd{C-z} to the @code{shell} command (@pxref{Interactive Shell}): @example -(global-set-key (kbd "C-z") 'shell) +(keymap-global-set "C-z" 'shell) @end example @noindent @@ -1861,69 +1861,24 @@ causes an error; it certainly isn't what you want. and mouse events: @example -(global-set-key (kbd "C-c y") 'clipboard-yank) -(global-set-key (kbd "C-M-q") 'query-replace) -(global-set-key (kbd "") 'flyspell-mode) -(global-set-key (kbd "C-") 'display-line-numbers-mode) -(global-set-key (kbd "C-") 'forward-sentence) -(global-set-key (kbd "") 'mouse-save-then-kill) -@end example - - Instead of using @code{kbd}, you can use a Lisp string or vector to -specify the key sequence. Using a string is simpler, but only works -for @acronym{ASCII} characters and Meta-modified @acronym{ASCII} -characters. For example, here's how to bind @kbd{C-x M-l} to -@code{make-symbolic-link} (@pxref{Copying and Naming}): - -@example -(global-set-key "\C-x\M-l" 'make-symbolic-link) -@end example - - To bind a key sequence including @key{TAB}, @key{RET}, @key{ESC}, or -@key{DEL}, the string should contain the Emacs Lisp escape sequence -@samp{\t}, @samp{\r}, @samp{\e}, or @samp{\d} respectively. Here is -an example which binds @kbd{C-x @key{TAB}} to @code{indent-rigidly} -(@pxref{Indentation}): - -@example -(global-set-key "\C-x\t" 'indent-rigidly) -@end example - - When the key sequence includes function keys or mouse button events, -or non-@acronym{ASCII} characters such as @code{C-=} or @code{H-a}, -you can use a vector to specify the key sequence. Each element in the -vector stands for an input event; the elements are separated by spaces -and surrounded by a pair of square brackets. If a vector element is a -character, write it as a Lisp character constant: @samp{?} followed by -the character as it would appear in a string. Function keys are -represented by symbols (@pxref{Function Keys}); simply write the -symbol's name, with no other delimiters or punctuation. Here are some -examples: - -@example -(global-set-key [?\C-=] 'make-symbolic-link) -(global-set-key [?\M-\C-=] 'make-symbolic-link) -(global-set-key [?\H-a] 'make-symbolic-link) -(global-set-key [f7] 'make-symbolic-link) -(global-set-key [C-mouse-1] 'make-symbolic-link) -@end example - -@noindent -You can use a vector for the simple cases too: - -@example -(global-set-key [?\C-z ?\M-l] 'make-symbolic-link) +(keymap-global-set "C-c y" 'clipboard-yank) +(keymap-global-set "C-M-q" 'query-replace) +(keymap-global-set "" 'flyspell-mode) +(keymap-global-set "C-" 'display-line-numbers-mode) +(keymap-global-set "C-" 'forward-sentence) +(keymap-global-set "" 'mouse-save-then-kill) @end example Language and coding systems may cause problems with key bindings for non-@acronym{ASCII} characters. @xref{Init Non-ASCII}. -@findex define-key +@findex keymap-set +@findex keymap-unset As described in @ref{Local Keymaps}, major modes and minor modes can define local keymaps. These keymaps are constructed when the mode is -loaded for the first time in a session. The function @code{define-key} -can be used to make changes in a specific keymap. This function can -also unset keys, when passed @code{nil} as the binding. +loaded for the first time in a session. The function @code{keymap-set} +can be used to make changes in a specific keymap. To remove a key +binding, use @code{keymap-unset}. Since a mode's keymaps are not constructed until it has been loaded, you must delay running code which modifies them, e.g., by putting it @@ -1935,11 +1890,11 @@ the one for @kbd{C-c C-x x} in Texinfo mode: @example (add-hook 'texinfo-mode-hook (lambda () - (define-key texinfo-mode-map "\C-cp" + (keymap-set texinfo-mode-map "C-c p" 'backward-paragraph) - (define-key texinfo-mode-map "\C-cn" + (keymap-set texinfo-mode-map "C-c n" 'forward-paragraph))) - (define-key texinfo-mode-map "\C-c\C-xx" nil) + (keymap-set texinfo-mode-map "C-c C-x x" nil) @end example @node Modifier Keys @@ -1961,7 +1916,7 @@ between those keystrokes. However, you can bind shifted @key{Control} alphabetical keystrokes in GUI frames: @lisp -(global-set-key (kbd "C-S-n") #'previous-line) +(keymap-global-set "C-S-n" #'previous-line) @end lisp For all other modifiers, you can make the modified alphabetical @@ -2115,7 +2070,7 @@ button, @code{mouse-2} for the next, and so on. Here is how you can redefine the second mouse button to split the current window: @example -(global-set-key [mouse-2] 'split-window-below) +(keymap-global-set "" 'split-window-below) @end example The symbols for drag events are similar, but have the prefix @@ -2198,7 +2153,7 @@ Thus, here is how to define the command for clicking the first button in a mode line to run @code{scroll-up-command}: @example -(global-set-key [mode-line mouse-1] 'scroll-up-command) +(keymap-global-set " " 'scroll-up-command) @end example Here is the complete list of these dummy prefix keys and their @@ -2589,13 +2544,13 @@ Rebind the key @kbd{C-x l} to run the function @code{make-symbolic-link} (@pxref{Init Rebinding}). @example -(global-set-key "\C-xl" 'make-symbolic-link) +(keymap-global-set "C-x l" 'make-symbolic-link) @end example or @example -(define-key global-map "\C-xl" 'make-symbolic-link) +(keymap-set global-map "C-x l" 'make-symbolic-link) @end example Note once again the single-quote used to refer to the symbol @@ -2605,7 +2560,7 @@ Note once again the single-quote used to refer to the symbol Do the same thing for Lisp mode only. @example -(define-key lisp-mode-map "\C-xl" 'make-symbolic-link) +(keymap-set lisp-mode-map "C-x l" 'make-symbolic-link) @end example @item @@ -2622,7 +2577,7 @@ so that they run @code{forward-line} instead. Make @kbd{C-x C-v} undefined. @example -(global-unset-key "\C-x\C-v") +(keymap-global-unset "C-x C-v") @end example One reason to undefine a key is so that you can make it a prefix. @@ -2798,18 +2753,6 @@ strings incorrectly. You should then avoid adding Emacs Lisp code that modifies the coding system in other ways, such as calls to @code{set-language-environment}. - To bind non-@acronym{ASCII} keys, you must use a vector (@pxref{Init -Rebinding}). The string syntax cannot be used, since the -non-@acronym{ASCII} characters will be interpreted as meta keys. For -instance: - -@example -(global-set-key [?@var{char}] 'some-function) -@end example - -@noindent -Type @kbd{C-q}, followed by the key you want to bind, to insert @var{char}. - @node Early Init File @subsection The Early Init File @cindex early init file diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 7ea754612ee..90044b1d4bb 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -716,46 +716,62 @@ frame: @table @code @item mode-line @cindex @code{mode-line} face -@cindex faces for mode lines -This face is used for the mode line of the currently selected window, +This is the base face used for the mode lines, as well as header lines and for menu bars when toolkit menus are not used. By default, it's drawn with shadows for a raised effect on graphical displays, and drawn as the inverse of the default face on non-windowed terminals. + +The @code{mode-line-active} and @code{mode-line-inactive} faces (which +are the ones used on the mode lines) inherit from this face. + +@item mode-line-active +@cindex faces for mode lines +Like @code{mode-line}, but used for the mode line of the currently +selected window. This face inherits from @code{mode-line}, so changes +in that face affect mode lines in all windows. + @item mode-line-inactive @cindex @code{mode-line-inactive} face Like @code{mode-line}, but used for mode lines of the windows other than the selected one (if @code{mode-line-in-non-selected-windows} is non-@code{nil}). This face inherits from @code{mode-line}, so changes in that face affect mode lines in all windows. + @item mode-line-highlight @cindex @code{mode-line-highlight} face Like @code{highlight}, but used for mouse-sensitive portions of text on mode lines. Such portions of text typically pop up tooltips (@pxref{Tooltips}) when the mouse pointer hovers above them. + @item mode-line-buffer-id @cindex @code{mode-line-buffer-id} face This face is used for buffer identification parts in the mode line. + @item header-line @cindex @code{header-line} face Similar to @code{mode-line} for a window's header line, which appears at the top of a window just as the mode line appears at the bottom. Most windows do not have a header line---only some special modes, such Info mode, create one. + @item header-line-highlight @cindex @code{header-line-highlight} face Similar to @code{highlight} and @code{mode-line-highlight}, but used for mouse-sensitive portions of text on header lines. This is a separate face because the @code{header-line} face might be customized in a way that does not interact well with @code{highlight}. + @item tab-line @cindex @code{tab-line} face Similar to @code{mode-line} for a window's tab line, which appears at the top of a window with tabs representing window buffers. @xref{Tab Line}. + @item vertical-border @cindex @code{vertical-border} face This face is used for the vertical divider between windows on text terminals. + @item minibuffer-prompt @cindex @code{minibuffer-prompt} face @vindex minibuffer-prompt-properties @@ -765,19 +781,23 @@ By default, Emacs automatically adds this face to the value of properties (@pxref{Text Properties,,, elisp, the Emacs Lisp Reference Manual}) used to display the prompt text. (This variable takes effect when you enter the minibuffer.) + @item fringe @cindex @code{fringe} face The face for the fringes to the left and right of windows on graphic displays. (The fringes are the narrow portions of the Emacs frame between the text area and the window's right and left borders.) @xref{Fringes}. + @item cursor The @code{:background} attribute of this face specifies the color of the text cursor. @xref{Cursor Display}. + @item tooltip This face is used for tooltip text. By default, if Emacs is built with GTK+ support, tooltips are drawn via GTK+ and this face has no effect. @xref{Tooltips}. + @item mouse This face determines the color of the mouse pointer. @end table diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 83847fb8f12..ce92435ae70 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -221,6 +221,7 @@ Appendices * X Resources:: X resources for customizing Emacs. * Antinews:: Information about Emacs version 27. * Mac OS / GNUstep:: Using Emacs under macOS and GNUstep. +* Haiku:: Using Emacs on Haiku. * Microsoft Windows:: Using Emacs on Microsoft Windows and MS-DOS. * Manifesto:: What's GNU? Gnu's Not Unix! @@ -1249,6 +1250,11 @@ Emacs and macOS / GNUstep * Mac / GNUstep Events:: How window system events are handled. * GNUstep Support:: Details on status of GNUstep support. +Emacs and Haiku + +* Haiku Basics:: Basic Emacs usage and installation under Haiku. +* Haiku Fonts:: The various options for displaying fonts on Haiku. + Emacs and Microsoft Windows/MS-DOS * Windows Startup:: How to start Emacs on Windows. @@ -1618,6 +1624,7 @@ Lisp programming. @include anti.texi @include macos.texi +@include haiku.texi @c Includes msdos-xtra. @include msdos.texi @include gnu.texi diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi new file mode 100644 index 00000000000..d2b7eb8408f --- /dev/null +++ b/doc/emacs/haiku.texi @@ -0,0 +1,124 @@ +@c This is part of the Emacs manual. +@c Copyright (C) 2021 Free Software Foundation, Inc. +@c See file emacs.texi for copying conditions. +@node Haiku +@appendix Emacs and Haiku +@cindex Haiku + + Haiku is a Unix-like operating system that originated as a +re-implementation of the operating system BeOS. + + This section describes the peculiarities of using Emacs built with +the Application Kit, the windowing system native to Haiku. The +oddities described here do not apply to using Emacs on Haiku built +without windowing support, or built with X11. + +@menu +* Haiku Basics:: Basic Emacs usage and installation under Haiku. +* Haiku Fonts:: The various options for displaying fonts on Haiku. +@end menu + +@node Haiku Basics +@section Installation and usage peculiarities under Haiku +@cindex haiku application +@cindex haiku installation + + Emacs installs two separate executables under Haiku; it is up to the +user to decide which one suits him best: A regular executable, with +the lowercase name @code{emacs}, and a binary containing +Haiku-specific application metadata, with the name @code{Emacs}. + +@cindex launching Emacs from the tracker +@cindex tty Emacs in haiku + If you are launching Emacs from the Tracker, or want to make the +Tracker open files using Emacs, you should use the binary named +@code{Emacs}; if you are going to use Emacs in the terminal, or wish +to launch separate instances of Emacs, or do not care for the +aforementioned system integration features, use the binary named +@code{emacs} instead. + +@cindex modifier keys and system keymap (Haiku) +@cindex haiku keymap + On Haiku, unusual modifier keys such as the Hyper key are +unsupported. By default, the super key corresponds with the option +key defined by the operating system, the meta key with the command +key, the control key with the system control key, and the shift key +with the system shift key. On a standard PC keyboard, Haiku should +map these keys to positions familiar to those using a GNU system, but +this may require some adjustment to your system's configuration to +work. + + It is impossible to type accented characters using the system super +key map. + + You can customize the correspondence between modifier keys known to +the system, and those known to Emacs. The variables that allow for +that are described below. + +@cindex modifier key customization (Haiku) +@table @code +@vindex haiku-meta-keysym +@item haiku-meta-keysym +The system modifier key that will be treated as the Meta key by Emacs. +It defaults to @code{command}. + +@vindex haiku-control-keysym +@item haiku-control-keysym +The system modifier key that will be treated as the Control key by +Emacs. It defaults to @code{control}. + +@vindex haiku-super-keysym +@item haiku-super-keysym +The system modifier key that will be treated as the Super key by +Emacs. It defaults to @code{option}. + +@vindex haiku-shift-keysym +@item haiku-shift-keysym +The system modifier key that will be treated as the Shift key by +Emacs. It defaults to @code{shift}. +@end table + +The value of each variable can be one of the symbols @code{command}, +@code{control}, @code{option}, @code{shift}, or @code{nil}. +@code{nil} or any other value will cause the default value to be used +instead. + +@cindex tooltips (haiku) +@cindex haiku tooltips +@vindex haiku-use-system-tooltips + On Haiku, Emacs defaults to using the system tooltip mechanism. +This usually leads to more responsive tooltips, but the tooltips will +not be able to display text properties or faces. If you need those +features, customize the variable @code{haiku-use-system-tooltips} to +the nil value, and Emacs will use its own implementation of tooltips. + + Both system tooltips and Emacs's own tooltips cannot display above +the menu bar, so help text in the menu bar will display in the echo +area instead. + +@subsection What to do when Emacs crashes +@cindex crashes, Haiku +@cindex haiku debugger +@vindex haiku-debug-on-fatal-error + If the variable @code{haiku-debug-on-fatal-error} is non-nil, Emacs +will launch the system debugger when a fatal signal is received. It +defaults to @code{t}. If GDB cannot be used on your system, please +attach the report generated by the system debugger when reporting a +bug. + +@node Haiku Fonts +@section Font and font backend selection on Haiku +@cindex font backend selection (Haiku) + + Emacs, when built with Haiku windowing support, can be built with +several different font backends. You can specify font backends by +specifying @kbd{-xrm Emacs.fontBackend:BACKEND} on the command line +used to invoke Emacs, where @kbd{BACKEND} is one of the backends +specified below, or on a per-frame basis by changing the +@code{font-backend} frame parameter. + + Two of these backends, @code{ftcr} and @code{ftcrhb} are identical +to their counterparts on the X Window System. There is also a +Haiku-specific backend named @code{haiku}, that uses the App Server to +draw fonts, but does not at present support display of color font and +emoji. diff --git a/doc/emacs/kmacro.texi b/doc/emacs/kmacro.texi index 78964bb903f..e0533f049ea 100644 --- a/doc/emacs/kmacro.texi +++ b/doc/emacs/kmacro.texi @@ -439,7 +439,7 @@ name to execute the last keyboard macro, in its current form. (If you later add to the definition of this macro, that does not alter the name's definition as a macro.) The macro name is a Lisp symbol, and defining it in this way makes it a valid command name for calling with -@kbd{M-x} or for binding a key to with @code{global-set-key} +@kbd{M-x} or for binding a key to with @code{keymap-global-set} (@pxref{Keymaps}). If you specify a name that has a prior definition other than a keyboard macro, an error message is shown and nothing is changed. diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 3d423d7675b..1f2c852fac1 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -3011,6 +3011,14 @@ the WebKit widget to display the next search result, while typing To leave incremental search, you can type @kbd{C-g}. +@findex xwidget-webkit-browse-history +@cindex history of webkit buffers + The command @code{xwidget-webkit-browse-history} displays a buffer +containing a list of pages previously loaded by the current WebKit +buffer, and lets you navigate to those pages by hitting @kbd{RET}. + +It is bound to @kbd{H}. + @node Browse-URL @subsection Following URLs @cindex World Wide Web diff --git a/doc/emacs/xresources.texi b/doc/emacs/xresources.texi index 00fa6c0aa31..a7bd006df4d 100644 --- a/doc/emacs/xresources.texi +++ b/doc/emacs/xresources.texi @@ -395,6 +395,8 @@ Background color. Foreground color for a selected item. @item foreground Foreground color. +@item disabledForeground +Foreground color for a disabled menu item. @ifnottex @item horizontalSpacing Horizontal spacing in pixels between items. Default is 3. @@ -406,6 +408,12 @@ the associated text. Default is 10. @item shadowThickness Thickness of shadow lines for 3D buttons, arrows, and other graphical elements. Default is 1. +@item borderThickness +Thickness of the external borders of the menu bars and pop-up menus. +Default is 1. +@item cursor +Name of the cursor to use in the menu bars and pop-up menus. Default +is @code{"right_ptr"}. @end ifnottex @item margin Margin of the menu bar, in characters. Default is 1. diff --git a/doc/lispref/anti.texi b/doc/lispref/anti.texi index 118df05c791..45cbff61e0b 100644 --- a/doc/lispref/anti.texi +++ b/doc/lispref/anti.texi @@ -135,7 +135,7 @@ the programmers should be trusted to know what they are doing. @item We deleted several features of the @code{pcase} macro, in accordance -with our general plane to remove @code{pcase} from Emacs: +with our general plan to remove @code{pcase} from Emacs: @itemize @minus @item diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 6ed46fa6a27..581183a0a39 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -451,7 +451,7 @@ reads and discards the following up-event. You can get access to that up-event with the @samp{U} code character. This kind of input is used by commands such as @code{describe-key} and -@code{global-set-key}. +@code{keymap-global-set}. @item K A key sequence on a form that can be used as input to functions like @@ -1559,8 +1559,10 @@ corner of @var{object}, which is @code{(0 . 0)}. If @var{object} is the top left corner of the character glyph clicked on. @item @var{width}, @var{height} -These are the pixel width and height of @var{object} or, if this is -@code{nil}, those of the character glyph clicked on. +If the click is on a character, either from buffer text or from +overlay or display string, these are the pixel width and height of +that character's glyph; otherwise they are dimensions of @var{object} +clicked on. @end table For clicks on a scroll bar, @var{position} has this form: @@ -1886,6 +1888,15 @@ This event is sent whenever some kind of update occurs in @var{xwidget}. There are several types of updates, identified by their @var{kind}. +@cindex xwidget callbacks +It is a special event (@pxref{Special Events}), which should be +handled by adding a callback to an xwidget that is called whenever an +xwidget event for @var{xwidget} is received. + +You can add a callback by setting the @code{callback} of an xwidget's +property list, which should be a function that accepts @var{xwidget} +and @var{kind} as arguments. + @table @code @cindex @code{load-changed} xwidget event @item load-changed @@ -1941,9 +1952,15 @@ internally by @code{xwidget-webkit-execute-script}. @end table @cindex @code{xwidget-display-event} event -@item (xwidget-display-event @var{xwidget}) +@item (xwidget-display-event @var{xwidget} @var{source}) This event is sent whenever an xwidget requests that another xwidget -be displayed. @var{xwidget} is the xwidget that should be displayed. +be displayed. @var{xwidget} is the xwidget that should be displayed, +and @var{source} is the xwidget that asked to display @var{xwidget}. + +It is also a special event which should be handled through callbacks. +You can add such a callback by setting the @code{display-callback} of +@var{source}'s property list, which should be a function that accepts +@var{xwidget} and @var{source} as arguments. @var{xwidget}'s buffer will be set to a temporary buffer. When displaying the widget, care should be taken to replace the buffer with @@ -1980,13 +1997,28 @@ frame has already been made visible, Emacs has no work to do. @cindex @code{wheel-up} event @cindex @code{wheel-down} event -@item (wheel-up @var{position}) -@itemx (wheel-down @var{position}) +@item (wheel-up @var{position} @var{clicks} @var{lines} @var{pixel-delta}) +@itemx (wheel-down @var{position} @var{clicks} @var{lines} @var{pixel-delta}) These kinds of event are generated by moving a mouse wheel. The @var{position} element is a mouse position list (@pxref{Click Events}), specifying the position of the mouse cursor when the event occurred. +@var{clicks}, if present, is the number of times in quick succession +the wheel has been moved. @xref{Repeat Events}. @var{lines}, if +present and not @code{nil}, is the number of screen lines that should +be scrolled. @var{pixel-delta}, if present, is a pair of the form +@w{@code{(@var{x} . @var{y})}}, where @var{x} and @var{y} are the +number of pixels to scroll by in each axis. + +@cindex pixel-resolution wheel events +You can use @var{x} and @var{y} to determine how much the mouse wheel +has actually moved at pixel resolution. + +For example, the pixelwise deltas could be used to scroll the display +at pixel resolution, exactly according to the user's turning the mouse +wheel. + @vindex mouse-wheel-up-event @vindex mouse-wheel-down-event This kind of event is generated only on some kinds of systems. On some @@ -2147,7 +2179,7 @@ bind it to the @code{signal usr1} event sequence: (defun usr1-handler () (interactive) (message "Got USR1 signal")) -(global-set-key [signal usr1] 'usr1-handler) +(keymap-global-set " " 'usr1-handler) @end smallexample @node Classifying Events @@ -3016,7 +3048,7 @@ supplied to input methods (@pxref{Input Methods}). Use if you want to translate characters after input methods operate. @end defvar -@defun keyboard-translate from to +@defun key-translate from to This function modifies @code{keyboard-translate-table} to translate character code @var{from} into character code @var{to}. It creates the keyboard translate table if necessary. @@ -3027,12 +3059,12 @@ make @kbd{C-x}, @kbd{C-c} and @kbd{C-v} perform the cut, copy and paste operations: @example -(keyboard-translate ?\C-x 'control-x) -(keyboard-translate ?\C-c 'control-c) -(keyboard-translate ?\C-v 'control-v) -(global-set-key [control-x] 'kill-region) -(global-set-key [control-c] 'kill-ring-save) -(global-set-key [control-v] 'yank) +(key-translate "C-x" "") +(key-translate "C-c" "") +(key-translate "C-v" "") +(keymap-global-set "" 'kill-region) +(keymap-global-set "" 'kill-ring-save) +(keymap-global-set "" 'yank) @end example @noindent diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi index b93b8bc015a..00287a7212a 100644 --- a/doc/lispref/customize.texi +++ b/doc/lispref/customize.texi @@ -737,7 +737,7 @@ If omitted, @var{key-type} and @var{value-type} default to The user can add any key matching the specified key type, but you can give some keys a preferential treatment by specifying them with the -@code{:options} (see @ref{Variable Definitions}). The specified keys +@code{:options} (@pxref{Variable Definitions}). The specified keys will always be shown in the customize buffer (together with a suitable value), with a checkbox to include or exclude or disable the key/value pair from the alist. The user will not be able to edit the keys diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index a8a7837a4a0..0bdbc06013e 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2052,14 +2052,14 @@ means hide the excess parts of @var{string} with a @code{display} text property (@pxref{Display Property}) showing the ellipsis, instead of actually truncating the string. -@group @example +@group (truncate-string-to-width "\tab\t" 12 4) @result{} "ab" (truncate-string-to-width "\tab\t" 12 4 ?\s) @result{} " ab " -@end example @end group +@end example This function uses @code{string-width} and @code{char-width} to find the suitable truncation point when @var{string} is too wide, so it @@ -2201,6 +2201,23 @@ though when this function is run from an idle timer with a delay of zero seconds. @end defun +@defun buffer-text-pixel-size &optional buffer-or-name window from to x-limit y-limit +This is much like @code{window-text-pixel-size}, but can be used when +the buffer isn't shown in a window. (@code{window-text-pixel-size} is +faster when it is, so this function shouldn't be used in that case.) + +@var{buffer-or-name} must specify a live buffer or the name of a live +buffer and defaults to the current buffer. @var{window} must be a +live window and defaults to the selected one; the function will +compute the text dimensions as if @var{buffer} is displayed in +@var{window}. The return value is a cons of the maximum pixel-width +of any text line and the pixel-height of all the text lines of the +buffer specified by @var{buffer-or-name}. + +The optional arguments @var{x-limit} and @var{y-limit} have the same +meaning as with @code{window-text-pixel-size}. +@end defun + @defun string-pixel-width string This is a convenience function that uses @code{window-text-pixel-size} to compute the width of @var{string} (in pixels). @@ -2767,8 +2784,9 @@ apply to. Here are the possible values of @var{characteristic}: @item type The kind of window system the terminal uses---either @code{graphic} (any graphics-capable display), @code{x}, @code{pc} (for the MS-DOS -console), @code{w32} (for MS Windows 9X/NT/2K/XP), or @code{tty} (a -non-graphics-capable display). @xref{Window Systems, window-system}. +console), @code{w32} (for MS Windows 9X/NT/2K/XP), @code{haiku} (for +Haiku), or @code{tty} (a non-graphics-capable display). +@xref{Window Systems, window-system}. @item class What kinds of colors the terminal supports---either @code{color}, @@ -4856,9 +4874,7 @@ window on a minibuffer-less frame. The @code{display} text property (or overlay property) is used to insert images into text, and to control other aspects of how text -displays. The value of the @code{display} property should be a -display specification, or a list or vector containing several display -specifications. Display specifications in the same @code{display} +displays. Display specifications in the same @code{display} property value generally apply in parallel to the text they cover. If several sources (overlays and/or a text property) specify values @@ -4866,6 +4882,50 @@ for the @code{display} property, only one of the values takes effect, following the rules of @code{get-char-property}. @xref{Examining Properties}. + The value of the @code{display} property should be a display +specification, or a list or vector containing several display +specifications. + +@defun get-display-property position prop &optional object properties +This convenience function can be used to get a specific display +property, no matter whether the @code{display} property is a vector, a +list or a simple property. This is like @code{get-text-property} +(@pxref{Examining Properties}), but works on the @code{display} +property only. + +@var{position} is the position in the buffer or string to examine, and +@var{prop} is the @code{display} property to return. The optional +@var{object} argument should be either a string or a buffer, and +defaults to the current buffer. If the optional @var{properties} +argument is non-@code{nil}, it should be a @code{display} property, +and in that case, @var{position} and @var{object} are ignored. (This +can be useful if you've already gotten the @code{display} property +with @code{get-char-property}, for instance (@pxref{Examining +Properties}). +@end defun + +@defun add-display-text-property start end prop value &optional object +Add @code{display} property @var{prop} of @var{value} to the text from +@var{start} to @var{end}. + +If any text in the region has a non-@code{nil} @code{display} +property, those properties are retained. For instance: + +@lisp +(add-display-text-property 4 8 'height 2.0) +(add-display-text-property 2 12 'raise 0.5) +@end lisp + +After doing this, the region from 2 to 4 will have the @code{raise} +@code{display} property, the region from 4 to 8 will have both the +@code{raise} and @code{height} @code{display} properties, and finally +the region from 8 to 12 will only have the @code{raise} @code{display} +property. + +If @var{object} is non-@code{nil}, it should be a string or a buffer. +If @code{nil}, this defaults to the current buffer. +@end defun + @cindex display property, unsafe evaluation @cindex security, and display specifications Some of the display specifications allow inclusion of Lisp forms, @@ -5141,6 +5201,24 @@ text that has the specification. It displays all of these spaces be an integer or float. Characters other than spaces are not affected at all; in particular, this has no effect on tab characters. +@item (min-width (@var{width})) +This display specification ensures the text that has it takes at least +@var{width} space on display, by adding a stretch of white space to +the end of the text if the text is shorter than @var{width}. The text +is partitioned using the identity of the parameter, which is why the +parameter is a list with one element. For instance: + +@lisp +(insert (propertize "foo" '(display (min-width (6.0))))) +@end lisp + +This will add padding after @samp{foo} bringing the total width up to +the width of six normal characters. Note that the affected characters +are identified by the @code{(6.0)} list in the display property, +compared with @code{eq}. The element @var{width} can be either an +integer or a float specifying the required minimum width of the text +(@pxref{Pixel Specification}). + @item (height @var{height}) This display specification makes the text taller or shorter. Here are the possibilities for @var{height}: @@ -6806,10 +6884,11 @@ widget that the newly created widget should share settings and subprocesses with. The xwidget that is returned will be killed alongside its buffer -(@pxref{Killing Buffers}). Once it is killed, the xwidget may -continue to exist as a Lisp object and act as a @code{display} -property until all references to it are gone, but most actions that -can be performed on live xwidgets will no longer be available. +(@pxref{Killing Buffers}). You can also kill it using +@code{kill-xwidget}. Once it is killed, the xwidget may continue to +exist as a Lisp object and act as a @code{display} property until all +references to it are gone, but most actions that can be performed on +live xwidgets will no longer be available. @end defun @defun xwidgetp object @@ -6822,6 +6901,12 @@ This function returns @code{t} if @var{object} is an xwidget that hasn't been killed, and @code{nil} otherwise. @end defun +@defun kill-xwidget xwidget +This function kills @var{xwidget}, by removing it from its buffer and +releasing window system resources it holds. +@end defun + +@cindex xwidget property list @defun xwidget-plist xwidget This function returns the property list of @var{xwidget}. @end defun @@ -6965,6 +7050,65 @@ the absolute location of the web resources referenced by @var{text}, to be used for resolving relative links in @var{text}. @end defun +@defun xwidget-webkit-goto-history xwidget rel-pos +Make @var{xwidget}, a WebKit widget, load the @var{rel-pos}th element +in its navigation history. + +If @var{rel-pos} is zero, the current page will be reloaded instead. +@end defun + +@defun xwidget-webkit-back-forward-list xwidget &optional limit +Return the navigation history of @var{xwidget}, up to @var{limit} +items in each direction. If not specified, @var{limit} defaults to +50. + +The returned value is a list of the form @w{@code{(@var{back} +@var{here} @var{forward})}}, where @var{here} is the current +navigation item, while @var{back} is a list of items containing the +items recorded by WebKit before the current navigation item, and +@var{forward} is a list of items recorded after the current navigation +item. @var{back}, @var{here} and @var{forward} can all be @code{nil}. + +When @var{here} is @code{nil}, it means that no items have been +recorded yet; if @var{back} or @var{forward} are @code{nil}, it means +that there is no history recorded before or after the current item +respectively. + +Navigation items are themselves lists of the form @w{@code{(@var{idx} +@var{title} @var{uri})}}. In these lists, @var{idx} is an index that +can be passed to @code{xwidget-webkit-goto-history}, @var{title} is +the human-readable title of the item, and @var{uri} is the URI of the +item. The user should normally have no reason to load @var{uri} +manually to reach a specific history item. Instead, @var{idx} should +be passed as an index to @code{xwidget-webkit-goto-history}. +@end defun + +@defun xwidget-webkit-estimated-load-progress xwidget +Return an estimate of how much data is remaining to be transferred +before the page displayed by the WebKit widget @var{xwidget} is fully +loaded. + +The value returned is a float ranging between 0.0 and 1.0. +@end defun + +@defun xwidget-webkit-set-cookie-storage-file xwidget file +Make the WebKit widget @var{xwidget} store cookies in @var{file}. + +@var{file} must be an absolute file name. The new setting will also +affect any xwidget that was created with @var{xwidget} as the +@code{related} argument to @code{make-xwidget}, and widgets related to +those as well. + +If this function is not called at least once on @var{xwidget} or a +related widget, @var{xwidget} will not store cookies on disk at all. +@end defun + +@defun xwidget-webkit-stop-loading xwidget +Terminate any data transfer still in progress in the WebKit widget +@var{xwidget} as part of a page-loading operation. If a page is not +being loaded, this function does nothing. +@end defun + @node Buttons @section Buttons @cindex buttons in buffers @@ -8208,6 +8352,8 @@ Emacs is displaying the frame using the Nextstep interface (used on GNUstep and macOS). @item pc Emacs is displaying the frame using MS-DOS direct screen writes. +@item haiku +Emacs is displaying the frame using the Application Kit on Haiku. @item nil Emacs is displaying the frame on a character-based terminal. @end table @@ -8254,6 +8400,7 @@ area. On text-mode (a.k.a.@: ``TTY'') frames, tooltips are always displayed in the echo area. @end defun +@cindex system tooltips @vindex x-gtk-use-system-tooltips When Emacs is built with GTK+ support, it by default displays tooltips using GTK+ functions, and the appearance of the tooltips is then diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 7d67cc3af11..0db77255a65 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1267,7 +1267,7 @@ balanced parentheses, recursive processing of forms, and recursion via indirect specifications. Here's a table of the possible elements of a specification list, with -their meanings (see @ref{Specification Examples}, for the referenced +their meanings (@pxref{Specification Examples}, for the referenced examples): @table @code diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 1c0b0fa1b5a..4f47a1d1bbd 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -840,6 +840,7 @@ Keymaps * Key Lookup:: Finding a key's binding in one keymap. * Functions for Key Lookup:: How to request key lookup. * Changing Key Bindings:: Redefining a key in a keymap. +* Low-Level Key Binding:: Legacy key syntax description. * Remapping Commands:: A keymap can translate one command to another. * Translation Keymaps:: Keymaps for translating sequences of events. * Key Binding Commands:: Interactive interfaces for redefining keys. diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index d93770a0d2f..4b114ba111d 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3308,8 +3308,8 @@ first, before handlers for jobs such as remote file access. @ifnottex @noindent -@code{access-file}, @code{add-name-to-file}, -@code{byte-compiler-base-file-name},@* +@code{abbreviate-file-name}, @code{access-file}, +@code{add-name-to-file}, @code{byte-compiler-base-file-name},@* @code{copy-directory}, @code{copy-file}, @code{delete-directory}, @code{delete-file}, @code{diff-latest-backup-file}, @@ -3368,7 +3368,8 @@ first, before handlers for jobs such as remote file access. @iftex @noindent @flushleft -@code{access-file}, @code{add-name-to-file}, +@code{abbreviate-file-name}, @code{access-file}, +@code{add-name-to-file}, @code{byte-com@discretionary{}{}{}piler-base-file-name}, @code{copy-directory}, @code{copy-file}, @code{delete-directory}, @code{delete-file}, diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 31ad82b7ada..923ff19997e 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -214,7 +214,8 @@ The terminal and keyboard coding systems used on the terminal. @item The kind of display associated with the terminal. This is the symbol returned by the function @code{terminal-live-p} (i.e., @code{x}, -@code{t}, @code{w32}, @code{ns}, or @code{pc}). @xref{Frames}. +@code{t}, @code{w32}, @code{ns}, @code{pc}, or @code{haiku}). +@xref{Frames}. @item A list of terminal parameters. @xref{Terminal Parameters}. @@ -680,7 +681,7 @@ indicate that position for the various builds: @itemize @w{} @item (1) non-toolkit and terminal frames -@item (2) Lucid, Motif and MS-Windows frames +@item (2) Lucid, Motif, MS-Windows, and Haiku frames @item (3) GTK+ and NS frames @end itemize @@ -1729,7 +1730,9 @@ fit will be clipped by the window manager. @item fullscreen This parameter specifies whether to maximize the frame's width, height or both. Its value can be @code{fullwidth}, @code{fullheight}, -@code{fullboth}, or @code{maximized}. A @dfn{fullwidth} frame is as +@code{fullboth}, or @code{maximized}.@footnote{On Haiku, setting +@code{fullscreen} to @code{fullwidth} or @code{fullheight} has no +effect.} A @dfn{fullwidth} frame is as wide as possible, a @dfn{fullheight} frame is as tall as possible, and a @dfn{fullboth} frame is both as wide and as tall as possible. A @dfn{maximized} frame is like a ``fullboth'' frame, except that it usually @@ -2191,7 +2194,10 @@ either via @code{focus-follows-mouse} (@pxref{Input Focus}) or @code{mouse-autoselect-window} (@pxref{Mouse Window Auto-selection}). This may have the unwanted side-effect that a user cannot scroll a non-selected frame with the mouse. Some window managers may not honor -this parameter. +this parameter. On Haiku, it also has the side-effect that the window +will not be able to receive any keyboard input from the user, not even +if the user switches to the frame using the key combination +@kbd{Alt-@key{TAB}}. @vindex undecorated@r{, a frame parameter} @item undecorated @@ -2352,7 +2358,10 @@ driver for OTF and TTF fonts with text shaping by the Uniscribe engine), and @code{harfbuzz} (font driver for OTF and TTF fonts with HarfBuzz text shaping) (@pxref{Windows Fonts,,, emacs, The GNU Emacs Manual}). The @code{harfbuzz} driver is similarly recommended. On -other systems, there is only one available font backend, so it does +Haiku, there can be several font drivers (@pxref{Haiku Fonts,,, emacs, +The GNU Emacs Manual}). + +On other systems, there is only one available font backend, so it does not make sense to modify this frame parameter. @vindex background-mode@r{, a frame parameter} @@ -3141,8 +3150,10 @@ raises @var{frame} above all other child frames of its parent. @deffn Command lower-frame &optional frame This function lowers frame @var{frame} (default, the selected frame) below all other frames belonging to the same or a higher z-group as -@var{frame}. If @var{frame} is a child frame (@pxref{Child Frames}), -this lowers @var{frame} below all other child frames of its parent. +@var{frame}.@footnote{Lowering frames is not supported on Haiku, due +to limitations imposed by the system.} If @var{frame} is a child +frame (@pxref{Child Frames}), this lowers @var{frame} below all other +child frames of its parent. @end deffn @defun frame-restack frame1 frame2 &optional above @@ -3152,7 +3163,8 @@ that if both frames are visible and their display areas overlap, third argument @var{above} is non-@code{nil}, this function restacks @var{frame1} above @var{frame2}. This means that if both frames are visible and their display areas overlap, @var{frame1} will (partially) -obscure @var{frame2}. +obscure @var{frame2}.@footnote{Restacking frames is not supported on +Haiku, due to limitations imposed by the system.} Technically, this function may be thought of as an atomic action performed in two steps: The first step removes @var{frame1}'s @@ -3247,12 +3259,16 @@ parent frame's window-system window. @cindex reparent frame @cindex nest frame - The @code{parent-frame} parameter can be changed at any time. Setting -it to another frame @dfn{reparents} the child frame. Setting it to -another child frame makes the frame a @dfn{nested} child frame. Setting -it to @code{nil} restores the frame's status as a top-level frame---a -frame whose window-system window is a child of its display's root -window. + The @code{parent-frame} parameter can be changed at any time. +Setting it to another frame @dfn{reparents} the child frame. Setting +it to another child frame makes the frame a @dfn{nested} child frame. +Setting it to @code{nil} restores the frame's status as a top-level +frame---a frame whose window-system window is a child of its display's +root window.@footnote{On Haiku, child frames are only visible when a +parent frame is active, owing to a limitation of the Haiku windowing +system. Owing to the same limitation, child frames are only +guaranteed to appear above their top-level parent; that is to say, the +top-most frame in the hierarchy, which does not have a parent frame.} Since child frames can be arbitrarily nested, a frame can be both a child and a parent frame. Also, the relative roles of child and parent diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index a788852de75..1a9eb30fde1 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -333,6 +333,13 @@ stands for no text itself. It is used only for a side effect: it specifies @var{mapvar}'s value as the keymap for any following @samp{\[@var{command}]} sequences in this documentation string. +@item \`@var{KEYSEQ}' +stands for a key sequence @var{KEYSEQ}, which will use the same face +as a command substitution. This should be used only when a key +sequence has no corresponding command, for example when it is read +directly with @code{read-key-sequence}. It must be a valid key +sequence according to @code{key-valid-p}. + @item ` (grave accent) stands for a left quote. This generates a left single quotation mark, an apostrophe, or a grave diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 899499ed46e..d893e22b8b9 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -30,6 +30,7 @@ is found. The whole process is called @dfn{key lookup}. * Key Lookup:: Finding a key's binding in one keymap. * Functions for Key Lookup:: How to request key lookup. * Changing Key Bindings:: Redefining a key in a keymap. +* Low-Level Key Binding:: Legacy key syntax description. * Remapping Commands:: A keymap can translate one command to another. * Translation Keymaps:: Keymaps for translating sequences of events. * Key Binding Commands:: Interactive interfaces for redefining keys. @@ -95,21 +96,11 @@ Manual}. (kbd "C-M-") @result{} [C-M-down] @end example -@findex kbd-valid-p +@findex key-valid-p The @code{kbd} function is very permissive, and will try to return something sensible even if the syntax used isn't completely conforming. To check whether the syntax is actually valid, use the -@code{kbd-valid-p} function. - -@code{define-key} also supports using the shorthand syntax -@samp{["..."]} syntax to define a key. The string has to be a -strictly valid @code{kbd} sequence, and if it's not valid, an error -will be signalled. For instance, to bind @key{C-c f}, you can say: - -@lisp -(define-key global-map ["C-c f"] #'find-file-literally) -@end lisp - +@code{key-valid-p} function. @end defun @@ -627,16 +618,16 @@ active keymap. @result{} nil @end group @group -(local-set-key "\C-p" ctl-x-map) +(keymap-local-set "C-p" ctl-x-map) @result{} nil @end group @group -(key-binding "\C-p\C-f") +(keymap-binding "C-p C-f") @result{} find-file @end group @group -(key-binding "\C-p6") +(keymap-binding "C-p 6") @result{} nil @end group @end example @@ -699,7 +690,7 @@ use, in place of the buffer's default local keymap. @cindex major mode keymap The local keymap is normally set by the buffer's major mode, and every buffer with the same major mode shares the same local keymap. -Hence, if you call @code{local-set-key} (@pxref{Key Binding Commands}) +Hence, if you call @code{keymap-local-set} (@pxref{Key Binding Commands}) to change the local keymap in one buffer, that also affects the local keymaps in other buffers with the same major mode. @@ -733,39 +724,7 @@ Normally it ignores @code{overriding-local-map} and then it pays attention to them. @var{position} can optionally be either an event position as returned by @code{event-start} or a buffer position, and may change the keymaps as described for -@code{key-binding}. -@end defun - -@defun key-binding key &optional accept-defaults no-remap position -This function returns the binding for @var{key} according to the -current active keymaps. The result is @code{nil} if @var{key} is -undefined in the keymaps. - -The argument @var{accept-defaults} controls checking for default -bindings, as in @code{lookup-key} (@pxref{Functions for Key Lookup}). - -When commands are remapped (@pxref{Remapping Commands}), -@code{key-binding} normally processes command remappings so as to -return the remapped command that will actually be executed. However, -if @var{no-remap} is non-@code{nil}, @code{key-binding} ignores -remappings and returns the binding directly specified for @var{key}. - -If @var{key} starts with a mouse event (perhaps following a prefix -event), the maps to be consulted are determined based on the event's -position. Otherwise, they are determined based on the value of point. -However, you can override either of them by specifying @var{position}. -If @var{position} is non-@code{nil}, it should be either a buffer -position or an event position like the value of @code{event-start}. -Then the maps consulted are determined based on @var{position}. - -Emacs signals an error if @var{key} is not a string or a vector. - -@example -@group -(key-binding "\C-x\C-f") - @result{} find-file -@end group -@end example +@code{keymap-binding}. @end defun @node Searching Keymaps @@ -1042,7 +1001,7 @@ keymap. Let's use the term @dfn{keymap entry} to describe the value found by looking up an event type in a keymap. (This doesn't include the item string and other extra elements in a keymap element for a menu item, because -@code{lookup-key} and other key lookup functions don't include them in +@code{keymap-lookup} and other key lookup functions don't include them in the returned value.) While any Lisp object may be stored in a keymap as a keymap entry, not all make sense for key lookup. Here is a table of the meaningful types of keymap entries: @@ -1193,7 +1152,7 @@ Used in keymaps to undefine keys. It calls @code{ding}, but does not cause an error. @end deffn -@defun local-key-binding key &optional accept-defaults +@defun keymap-local-binding key &optional accept-defaults This function returns the binding for @var{key} in the current local keymap, or @code{nil} if it is undefined there. @@ -1201,7 +1160,7 @@ The argument @var{accept-defaults} controls checking for default bindings, as in @code{lookup-key} (above). @end defun -@defun global-key-binding key &optional accept-defaults +@defun keymap-global-binding key &optional accept-defaults This function returns the binding for command @var{key} in the current global keymap, or @code{nil} if it is undefined there. @@ -1284,65 +1243,55 @@ change a binding in the global keymap, the change is effective in all buffers (though it has no direct effect in buffers that shadow the global binding with a local one). If you change the current buffer's local map, that usually affects all buffers using the same major mode. -The @code{global-set-key} and @code{local-set-key} functions are +The @code{keymap-global-set} and @code{keymap-local-set} functions are convenient interfaces for these operations (@pxref{Key Binding -Commands}). You can also use @code{define-key}, a more general +Commands}). You can also use @code{keymap-set}, a more general function; then you must explicitly specify the map to change. When choosing the key sequences for Lisp programs to rebind, please follow the Emacs conventions for use of various keys (@pxref{Key Binding Conventions}). -@cindex meta character key constants -@cindex control character key constants - @code{define-key} (and other functions that are used to rebind keys) -understand a number of different syntaxes for the keys. + The functions below signal an error if @var{keymap} is not a keymap, +or if @var{key} is not a valid key. -@table @asis -@item A vector containing a single string. -This is the preferred way to represent a key sequence. Here's a -couple of examples: +@var{key} is a string representing a single key or a series of key +strokes. Key strokes are separated by a single space character. -@example -["C-c M-f"] -["S-"] -@end example +Each key stroke is either a single character, or the name of an +event, surrounded by angle brackets. In addition, any key stroke +may be preceded by one or more modifier keys. Finally, a limited +number of characters have a special shorthand syntax. Here's some +example key sequences: -The syntax is the same as the one used by Emacs when displaying key -bindings, for instance in @samp{*Help*} buffers and help texts. +@table @kbd +@item f +The key @kbd{f}. -If the syntax isn't valid, an error will be raised when running -@code{define-key}, or when byte-compiling code that has these calls. +@item S o m +A three key sequence of the keys @kbd{S}, @kbd{o} and @kbd{m}. -@item A vector containing lists of keys. -You can use a list containing modifier names plus one base event (a -character or function key name). For example, @code{[(control ?a) -(meta b)]} is equivalent to @kbd{C-a M-b} and @code{[(hyper control -left)]} is equivalent to @kbd{C-H-left}. +@item C-c o +A two key sequence of the keys @kbd{c} with the control modifier and +then the key @kbd{o} -@item A string with control and meta characters. -Internally, key sequences are often represented as strings using the -special escape sequences for control and meta characters -(@pxref{String Type}), but this representation can also be used by -users when rebinding keys. A string like @code{"\M-x"} is read as -containing a single @kbd{M-x}, @code{"\C-f"} is read as containing a -single @kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both -read as containing a single @kbd{C-M-x}. +@item H- +The key named @kbd{left} with the hyper modifier. -@item a vector of characters. -This is the other internal representation of key sequences, and -supports a fuller range of modifiers than the string representation. -One example is @samp{[?\C-\H-x home]}, which represents the @kbd{C-H-x -home} key sequence. @xref{Character Type}. +@item M-RET +The @kbd{return} key with a meta modifier. + +@item C-M- +The @kbd{space} key with both the control and meta modifiers. @end table - The functions below signal an error if @var{keymap} is not a keymap, -or if @var{key} is not a string or vector representing a key sequence. -You can use event types (symbols) as shorthand for events that are -lists. The @code{kbd} function (@pxref{Key Sequences}) is a -convenient way to specify the key sequence. +The only keys that have a special shorthand syntax are @kbd{NUL}, +@kbd{RET}, @kbd{TAB}, @kbd{LFD}, @kbd{ESC}, @kbd{SPC} and @kbd{DEL}. -@defun define-key keymap key binding +The modifiers have to be specified in alphabetical order: +@samp{A-C-H-M-S-s}, which is @samp{Alt-Control-Hyper-Meta-Shift-super}. + +@defun keymap-set keymap key binding This function sets the binding for @var{key} in @var{keymap}. (If @var{key} is more than one event long, the change is actually made in another keymap reached from @var{keymap}.) The argument @@ -1350,7 +1299,7 @@ in another keymap reached from @var{keymap}.) The argument meaningful. (For a list of meaningful types, see @ref{Key Lookup}.) The value returned by @code{define-key} is @var{binding}. -If @var{key} is @code{[t]}, this sets the default binding in +If @var{key} is @kbd{}, this sets the default binding in @var{keymap}. When an event has no binding of its own, the Emacs command loop uses the keymap's default binding, if there is one. @@ -1358,7 +1307,7 @@ command loop uses the keymap's default binding, if there is one. @cindex key sequence error Every prefix of @var{key} must be a prefix key (i.e., bound to a keymap) or undefined; otherwise an error is signaled. If some prefix of -@var{key} is undefined, then @code{define-key} defines it as a prefix +@var{key} is undefined, then @code{keymap-set} defines it as a prefix key so that the rest of @var{key} can be defined as specified. If there was previously no binding for @var{key} in @var{keymap}, the @@ -1376,7 +1325,7 @@ bindings in it: @result{} (keymap) @end group @group -(define-key map ["C-f"] 'forward-char) +(keymap-set map "C-f" 'forward-char) @result{} forward-char @end group @group @@ -1386,7 +1335,7 @@ map @group ;; @r{Build sparse submap for @kbd{C-x} and bind @kbd{f} in that.} -(define-key map ["C-x f"] 'forward-word) +(keymap-set map "C-x f" 'forward-word) @result{} forward-word @end group @group @@ -1399,14 +1348,14 @@ map @group ;; @r{Bind @kbd{C-p} to the @code{ctl-x-map}.} -(define-key map ["C-p"] ctl-x-map) +(keymap-set map "C-p" ctl-x-map) ;; @code{ctl-x-map} @result{} [nil @dots{} find-file @dots{} backward-kill-sentence] @end group @group ;; @r{Bind @kbd{C-f} to @code{foo} in the @code{ctl-x-map}.} -(define-key map ["C-p C-f"] 'foo) +(keymap-set map "C-p C-f" 'foo) @result{} 'foo @end group @group @@ -1426,9 +1375,9 @@ changing the bindings of both @kbd{C-p C-f} and @kbd{C-x C-f} in the default global map. @defun define-keymap &key options... &rest pairs... -@code{define-key} is the general work horse for defining a key in a +@code{keymap-set} is the general work horse for defining a key in a keymap. When writing modes, however, you frequently have to bind a -large number of keys at once, and using @code{define-key} on them all +large number of keys at once, and using @code{keymap-set} on them all can be tedious and error-prone. Instead you can use @code{define-keymap}, which creates a keymaps and binds a number of keys. Here's a very basic example: @@ -1437,14 +1386,14 @@ keys. Here's a very basic example: (define-keymap "n" #'forward-line "f" #'previous-line - ["C-c C-c"] #'quit-window) + "C-c C-c" #'quit-window) @end lisp This function creates a new sparse keymap, defines the two keystrokes in @var{pairs}, and returns the new keymap. @var{pairs} is a list of alternating key bindings and key definitions, -as accepted by @code{define-key}. In addition the key can be the +as accepted by @code{keymap-set}. In addition the key can be the special symbol @code{:menu}, in which case the definition should be a menu definition as accepted by @code{easy-menu-define} (@pxref{Easy Menu}). Here's a brief example: @@ -1513,8 +1462,8 @@ Here's an example: @lisp (defvar-keymap eww-textarea-map :parent text-mode-map - "\r" #'forward-line - [?\t] #'shr-next-link) + "RET" #'forward-line + "TAB" #'shr-next-link) @end lisp @end defmac @@ -1617,13 +1566,166 @@ Modes}); then its keymap will automatically inherit from (defvar special-mode-map (let ((map (make-sparse-keymap))) (suppress-keymap map) - (define-key map "q" 'quit-window) + (keymap-set map "q" 'quit-window) @dots{} map)) @end group @end smallexample @end defun +@node Low-Level Key Binding +@section Low-Level Key Binding +@cindex low-level key bindings + + Historically, Emacs has supported a number of different syntaxes for +defining keys. The documented way to bind a key today is to use the +syntax supported by @code{key-valid-p}, which is what all the +functions like @code{keymap-set} and @code{keymap-lookup} supports. +This section documents the old-style syntax and interface functions; +they should not be used in new code. + +@cindex meta character key constants +@cindex control character key constants + @code{define-key} (and other low-level functions that are used to +rebind keys) understand a number of different syntaxes for the keys. + +@table @asis +@item A vector containing lists of keys. +You can use a list containing modifier names plus one base event (a +character or function key name). For example, @code{[(control ?a) +(meta b)]} is equivalent to @kbd{C-a M-b} and @code{[(hyper control +left)]} is equivalent to @kbd{C-H-left}. + +@item A string of characters with modifiers +Internally, key sequences are often represented as strings using the +special escape sequences for shift, control and meta modifiers +(@pxref{String Type}), but this representation can also be used by +users when rebinding keys. A string like @code{"\M-x"} is read as +containing a single @kbd{M-x}, @code{"\C-f"} is read as containing a +single @kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both +read as containing a single @kbd{C-M-x}. + +@item A vector of characters and key symbols +This is the other internal representation of key sequences. It +supports a fuller range of modifiers than the string representation, +and also support function keys. An example is @w{@samp{[?\C-\H-x +home]}}, which represents the @w{@kbd{C-H-x @key{home}}} key sequence. +@xref{Character Type}. +@end table + +@defun define-key keymap key binding &optional remove +This function is like @code{keymap-set} (@pxref{Changing Key +Bindings}, but understands only the legacy key syntaxes. + +In addition, this function also has a @var{remove} argument. If it is +non-@code{nil}, the definition will be removed. This is almost the +same as setting the definition to @code{nil}, but makes a difference +if the @var{keymap} has a parent, and @var{key} is shadowing the same +binding in the parent. With @var{remove}, subsequent lookups will +return the binding in the parent, and with a nil @var{def}, the +lookups will return @code{nil}. +@end defun + +Here are other legacy key definition functions and commands, with the +equivalent modern function to use instead in new code. + +@deffn Command global-set-key key binding +This function sets the binding of @var{key} in the current global map +to @var{binding}. Use @code{keymap-global-set} instead. +@end deffn + +@deffn Command global-unset-key key +This function removes the binding of @var{key} from the current +global map. Use @code{keymap-global-unset} instead. +@end deffn + +@deffn Command local-set-key key binding +This function sets the binding of @var{key} in the current local +keymap to @var{binding}. Use @code{keymap-local-set} instead. +@end deffn + +@deffn Command local-unset-key key +This function removes the binding of @var{key} from the current +local map. Use @code{keymap-local-unset} instead. +@end deffn + +@defun substitute-key-definition olddef newdef keymap &optional oldmap +This function replaces @var{olddef} with @var{newdef} for any keys in +@var{keymap} that were bound to @var{olddef}. In other words, +@var{olddef} is replaced with @var{newdef} wherever it appears. The +function returns @code{nil}. Use @code{keymap-substitute} instead. +@end defun + +@defun define-key-after map key binding &optional after +Define a binding in @var{map} for @var{key}, with value @var{binding}, +just like @code{define-key}, but position the binding in @var{map} after +the binding for the event @var{after}. The argument @var{key} should be +of length one---a vector or string with just one element. But +@var{after} should be a single event type---a symbol or a character, not +a sequence. The new binding goes after the binding for @var{after}. If +@var{after} is @code{t} or is omitted, then the new binding goes last, at +the end of the keymap. However, new bindings are added before any +inherited keymap. Use @code{keymap-set-after} instead of this function. +@end defun + +@defun keyboard-translate from to +This function modifies @code{keyboard-translate-table} to translate +character code @var{from} into character code @var{to}. It creates +the keyboard translate table if necessary. Use @code{key-translate} +instead. +@end defun + +@defun key-binding key &optional accept-defaults no-remap position +This function returns the binding for @var{key} according to the +current active keymaps. The result is @code{nil} if @var{key} is +undefined in the keymaps. The argument @var{accept-defaults} controls +checking for default bindings, as in @code{lookup-key} +(@pxref{Functions for Key Lookup}). If @var{no-remap} is +non-@code{nil}, @code{key-binding} ignores command remappings +(@pxref{Remapping Commands}) and returns the binding directly +specified for @var{key}. The optional argument @var{position} should +be either a buffer position or an event position like the value of +@code{event-start}; it tells the function to consult the maps +determined based on that @var{position}. + +Emacs signals an error if @var{key} is not a string or a vector. + +Use @code{keymap-lookup} instead of this function. +@end defun + +@defun lookup-key keymap key &optional accept-defaults +This function returns the definition of @var{key} in @var{keymap}. If +the string or vector @var{key} is not a valid key sequence according +to the prefix keys specified in @var{keymap}, it must be too long and +have extra events at the end that do not fit into a single key +sequence. Then the value is a number, the number of events at the +front of @var{key} that compose a complete key. + +If @var{accept-defaults} is non-@code{nil}, then @code{lookup-key} +considers default bindings as well as bindings for the specific events +in @var{key}. Otherwise, @code{lookup-key} reports only bindings for +the specific sequence @var{key}, ignoring default bindings except when +you explicitly ask about them. + +Use @code{keymap-lookup} instead of this function. +@end defun + +@defun local-key-binding key &optional accept-defaults +This function returns the binding for @var{key} in the current +local keymap, or @code{nil} if it is undefined there. + +The argument @var{accept-defaults} controls checking for default bindings, +as in @code{lookup-key} (above). +@end defun + +@defun global-key-binding key &optional accept-defaults +This function returns the binding for command @var{key} in the +current global keymap, or @code{nil} if it is undefined there. + +The argument @var{accept-defaults} controls checking for default bindings, +as in @code{lookup-key} (above). +@end defun + @node Remapping Commands @section Remapping Commands @cindex remapping commands @@ -1834,32 +1936,18 @@ problematic suffixes/prefixes are @kbd{@key{ESC}}, @kbd{M-O} (which is really This section describes some convenient interactive interfaces for changing key bindings. They work by calling @code{define-key}. - People often use @code{global-set-key} in their init files + People often use @code{keymap-global-set} in their init files (@pxref{Init File}) for simple customization. For example, @smallexample -(global-set-key (kbd "C-x C-\\") 'next-line) -@end smallexample - -@noindent -or - -@smallexample -(global-set-key [?\C-x ?\C-\\] 'next-line) -@end smallexample - -@noindent -or - -@smallexample -(global-set-key [(control ?x) (control ?\\)] 'next-line) +(keymap-global-set "C-x C-\\" 'next-line) @end smallexample @noindent redefines @kbd{C-x C-\} to move down a line. @smallexample -(global-set-key [M-mouse-1] 'mouse-set-point) +(keymap-global-set "M-" 'mouse-set-point) @end smallexample @noindent @@ -1873,14 +1961,7 @@ they usually will be in a Lisp file (@pxref{Loading Non-ASCII}), you must type the keys as multibyte too. For instance, if you use this: @smallexample -(global-set-key "ö" 'my-function) ; bind o-umlaut -@end smallexample - -@noindent -or - -@smallexample -(global-set-key ?ö 'my-function) ; bind o-umlaut +(keymap-global-set "ö" 'my-function) ; bind o-umlaut @end smallexample @noindent @@ -1891,20 +1972,20 @@ binding, you need to teach Emacs how to decode the keyboard by using an appropriate input method (@pxref{Input Methods, , Input Methods, emacs, The GNU Emacs Manual}). -@deffn Command global-set-key key binding +@deffn Command keymap-global-set key binding This function sets the binding of @var{key} in the current global map to @var{binding}. @smallexample @group -(global-set-key @var{key} @var{binding}) +(keymap-global-set @var{key} @var{binding}) @equiv{} -(define-key (current-global-map) @var{key} @var{binding}) +(keymap-set (current-global-map) @var{key} @var{binding}) @end group @end smallexample @end deffn -@deffn Command global-unset-key key +@deffn Command keymap-global-unset key @cindex unbinding keys This function removes the binding of @var{key} from the current global map. @@ -1915,50 +1996,32 @@ that uses @var{key} as a prefix---which would not be allowed if @smallexample @group -(global-unset-key "\C-l") +(keymap-global-unset "C-l") @result{} nil @end group @group -(global-set-key "\C-l\C-l" 'redraw-display) +(keymap-global-set "C-l C-l" 'redraw-display) @result{} nil @end group @end smallexample - -This function is equivalent to using @code{define-key} as follows: - -@smallexample -@group -(global-unset-key @var{key}) -@equiv{} -(define-key (current-global-map) @var{key} nil) -@end group -@end smallexample @end deffn -@deffn Command local-set-key key binding +@deffn Command keymap-local-set key binding This function sets the binding of @var{key} in the current local keymap to @var{binding}. @smallexample @group -(local-set-key @var{key} @var{binding}) +(keymap-local-set @var{key} @var{binding}) @equiv{} -(define-key (current-local-map) @var{key} @var{binding}) +(keymap-set (current-local-map) @var{key} @var{binding}) @end group @end smallexample @end deffn -@deffn Command local-unset-key key +@deffn Command keymap-local-unset key This function removes the binding of @var{key} from the current local map. - -@smallexample -@group -(local-unset-key @var{key}) -@equiv{} -(define-key (current-local-map) @var{key} nil) -@end group -@end smallexample @end deffn @node Scanning Keymaps @@ -2813,9 +2876,9 @@ using an indirection through @code{tool-bar-map}. By default, the global map binds @code{[tool-bar]} as follows: @example -(global-set-key [tool-bar] - `(menu-item ,(purecopy "tool bar") ignore - :filter tool-bar-make-keymap)) +(keymap-global-set "" + `(menu-item ,(purecopy "tool bar") ignore + :filter tool-bar-make-keymap)) @end example @noindent diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 1fbd66458a4..fb0f25fa3d7 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -947,6 +947,9 @@ actually Linux is just the kernel, not the whole system.) @item gnu/kfreebsd A GNU (glibc-based) system with a FreeBSD kernel. +@item haiku +The Haiku operating system, a derivative of the Be Operating System. + @item hpux Hewlett-Packard HPUX operating system. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 937680c200d..863b318c205 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3650,9 +3650,20 @@ property is obsolete; use the @code{cursor-intangible} property instead. @item cursor-intangible @kindex cursor-intangible @r{(text property)} @findex cursor-intangible-mode +@cindex rear-nonsticky, and cursor-intangible property When the minor mode @code{cursor-intangible-mode} is turned on, point is moved away from any position that has a non-@code{nil} @code{cursor-intangible} property, just before redisplay happens. +Note that ``stickiness'' of the property (@pxref{Sticky Properties}) +is taken into account when computing allowed cursor positions, so (for +instance) to insert a stretch of five @samp{x} characters into which +the cursor can't enter, you should do something like: + +@lisp +(insert + (propertize "xxxx" 'cursor-intangible t) + (propertize "x" 'cursor-intangible t 'rear-nonsticky t)) +@end lisp @vindex cursor-sensor-inhibit When the variable @code{cursor-sensor-inhibit} is non-@code{nil}, the @@ -3950,6 +3961,8 @@ of the kill ring. To insert with inheritance, use the special primitives described in this section. Self-inserting characters inherit properties because they work using these primitives. +@cindex front-sticky text property +@cindex rear-nonsticky text property When you do insertion with inheritance, @emph{which} properties are inherited, and from where, depends on which properties are @dfn{sticky}. Insertion after a character inherits those of its properties that are diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index d2247004bcb..1ae0e5e5ee1 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -363,7 +363,7 @@ where you are in Emacs. @cindex evaluation error @cindex infinite recursion This variable defines the limit on the total number of local variable -bindings and @code{unwind-protect} cleanups (see @ref{Cleanups,, +bindings and @code{unwind-protect} cleanups (@pxref{Cleanups,, Cleaning Up from Nonlocal Exits}) that are allowed before Emacs signals an error (with data @code{"Variable binding depth exceeds max-specpdl-size"}). diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index d718ac59be6..f8dcca72cc0 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -6419,7 +6419,9 @@ changed. @xref{Other Font Lock Variables}. during redisplay provided a significant, non-scrolling change of a window has been detected. For simplicity, these hooks and the functions they call will be collectively referred to as @dfn{window -change functions}. +change functions}. As any hook, these hooks can be set either +globally of buffer-locally via the @var{local} argument of +@code{add-hook} (@pxref{Setting Hooks}) when the hook is installed. @cindex window buffer change The first of these hooks is run after a @dfn{window buffer change} is diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 18342e65b0a..757418a67ca 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -151,7 +151,7 @@ and @key{Meta} @item @key{DEL}: @key{Delete}, usually @strong{not} the same as -@key{Backspace}; same as @kbd{C-?} (see @ref{Backspace invokes help}, if +@key{Backspace}; same as @kbd{C-?} (@pxref{Backspace invokes help}, if deleting invokes Emacs help) @item @@ -793,7 +793,7 @@ informational files about Emacs and relevant aspects of the GNU project are available for you to read. The following files (and others) are available in the @file{etc} -directory of the Emacs distribution (see @ref{File-name conventions}, if +directory of the Emacs distribution (@pxref{File-name conventions}, if you're not sure where that is). Many of these files are available via the Emacs @samp{Help} menu, or by typing @kbd{C-h ?} (@kbd{M-x help-for-help}). @@ -1086,7 +1086,7 @@ Emacs Lisp form at point. @cindex pasting text on text terminals @cindex bracketed paste mode @item -On text terminals that support the ``bracketed paste mode'' EMacs now +On text terminals that support the ``bracketed paste mode'' Emacs now uses that mode by default. This mode allows Emacs to distinguish between pasted text and text typed by the user. @@ -2542,12 +2542,12 @@ load @code{dired-x} by adding the following to your @file{.emacs} file: (require 'dired-x)) @end lisp -With @code{dired-x} loaded, @kbd{M-o} toggles omitting in each dired buffer. +With @code{dired-x} loaded, @kbd{C-x M-o} toggles omitting in each dired buffer. You can make omitting the default for new dired buffers by putting the following in your @file{.emacs}: @lisp -(add-hook 'dired-mode-hook 'dired-omit-toggle) +(add-hook 'dired-mode-hook 'dired-omit-mode) @end lisp If you're tired of seeing backup files whenever you do an @samp{ls} at diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 7cd3e5f5828..96a4ad556f6 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -454,7 +454,8 @@ setting this option to non-@code{nil}. The default value is @code{t}. @item mm-external-terminal-program @vindex mm-external-terminal-program -The program used to start an external terminal. +This should be a list of strings; typically something like +@samp{("xterm" "-e")} or @samp{("gnome-terminal" "--")}. @item mm-enable-external @vindex mm-enable-external diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 440c61add8e..af215482f41 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -390,12 +390,37 @@ summary as shown below: emacs -batch -l ert -f ert-summarize-tests-batch-and-exit output.log @end example +@vindex ert-batch-print-level +@vindex ert-batch-print-length +ERT attempts to limit the output size for failed tests by choosing +conservative values for @code{print-level} and @code{print-length} +when printing Lisp values. This can in some cases make it difficult +to see which portions of those values are incorrect. Use +@code{ert-batch-print-level} and @code{ert-batch-print-length} +to customize that: + +@example +emacs -batch -l ert -l my-tests.el \ + --eval "(let ((ert-batch-print-level 10) \ + (ert-batch-print-length 120)) \ + (ert-run-tests-batch-and-exit))" +@end example + +@vindex ert-batch-backtrace-line-length +Even modest settings for @code{print-level} and @code{print-length} can +produce extremely long lines in backtraces, however, with attendant +pauses in execution progress. Set +@code{ert-batch-backtrace-line-length} to t to use the value of +@code{backtrace-line-length}, @code{nil} to stop any limitations on backtrace +line lengths (that is, to get full backtraces), or a positive integer to +limit backtrace line length to that number. + @vindex ert-quiet By default, ERT in batch mode is quite verbose, printing a line with result after each test. This gives you progress information: how many tests have been executed and how many there are. However, in some cases this much output may be undesirable. In this case, set -@code{ert-quiet} variable to a non-nil value: +@code{ert-quiet} variable to a non-@code{nil} value: @example emacs -batch -l ert -l my-tests.el \ diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index f741ee5d723..ca464aff665 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -1,4 +1,4 @@ -\input texinfo @c -*-texinfo; coding: utf-8 -*- +\input texinfo @c -*- mode: texinfo; coding: utf-8 -*- @comment %**start of header @setfilename ../../info/flymake.info @set VERSION 1.2 @@ -1145,7 +1145,7 @@ file are parsed. For @file{file.h}, the include directives to look for are @code{#include "file.h"}, @code{#include "../file.h"}, etc. Each include is checked against a list of include directories -(see @ref{Getting the include directories}) to be sure it points to the +(@pxref{Getting the include directories}) to be sure it points to the correct @file{file.h}. First matching master file found stops the search. The master file is then diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 796bb3bac84..a18afec02e8 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -1004,7 +1004,7 @@ The fundamental building blocks of Gnus are @dfn{servers}, @dfn{groups}, and @dfn{articles}. Servers can be local or remote. Each server maintains a list of groups, and those groups contain articles. Because Gnus presents a unified interface to a wide variety -of servers, the vocabulary doesn't always quite line up (see @ref{FAQ +of servers, the vocabulary doesn't always quite line up (@pxref{FAQ - Glossary}, for a more complete glossary). Thus a local maildir is referred to as a ``server'' (@pxref{Finding the News}) the same as a Usenet or IMAP server is; ``groups'' (@pxref{Group Buffer}) might mean @@ -28890,7 +28890,7 @@ gnus-agent-cache nil)} reverts to the old behavior. @item Dired integration -@code{gnus-dired-minor-mode} (see @ref{Other modes}) installs key +@code{gnus-dired-minor-mode} (@pxref{Other modes}) installs key bindings in dired buffers to send a file as an attachment, open a file using the appropriate mailcap entry, and print a file using the mailcap entry. diff --git a/doc/misc/htmlfontify.texi b/doc/misc/htmlfontify.texi index 1674565cdac..b2216924e2d 100644 --- a/doc/misc/htmlfontify.texi +++ b/doc/misc/htmlfontify.texi @@ -633,7 +633,7 @@ Convert an Emacs :foreground property to a CSS color property. (hfy-flatten-style @var{style}) @end lisp -Take @var{style} (see @ref{hfy-face-to-style-i}, @ref{hfy-face-to-style}) +Take @var{style} (@pxref{hfy-face-to-style-i}, @pxref{hfy-face-to-style}) and merge any multiple attributes appropriately. Currently only font-size is merged down to a single occurrence---others may need special handling, but I haven't encountered them yet. Returns a @ref{hfy-style-assoc}. @@ -841,7 +841,7 @@ See @ref{hfy-display-class} for details of valid values for @var{class}. @end lisp Find face in effect at point P@. If overlays are to be considered -(see @ref{hfy-optimizations}) then this may return a @code{defface} style +(@pxref{hfy-optimizations}) then this may return a @code{defface} style list of face properties instead of a face symbol. @item hfy-bgcol diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi index bc788ebae09..d96c243f52b 100644 --- a/doc/misc/mh-e.texi +++ b/doc/misc/mh-e.texi @@ -1018,16 +1018,16 @@ Send multimedia messages (@pxref{Adding Attachments}). Read HTML messages (@pxref{HTML}). @c ------------------------- @item -Use aliases and identities (see @ref{Aliases}, @pxref{Identities}). +Use aliases and identities (@pxref{Aliases}, @pxref{Identities}). @c ------------------------- @item -Create different views of your mail (see @ref{Threading}, @pxref{Limits}). +Create different views of your mail (@pxref{Threading}, @pxref{Limits}). @c ------------------------- @item Deal with junk mail (@pxref{Junk}). @c ------------------------- @item -Handle signed and encrypted messages (see @ref{Reading PGP}, +Handle signed and encrypted messages (@pxref{Reading PGP}, @pxref{Sending PGP}). @c ------------------------- @item @@ -1038,7 +1038,7 @@ Process mail that was sent with @command{shar} or @command{uuencode} Use sequences conveniently (@pxref{Sequences}). @c ------------------------- @item -Use the speedbar, tool bar, and menu bar (see @ref{Speedbar}, see @ref{Tool +Use the speedbar, tool bar, and menu bar (@pxref{Speedbar}, @pxref{Tool Bar}, @pxref{Menu Bar}). @c ------------------------- @item diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 675144d5177..f3c2e37b7dd 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -5,9 +5,9 @@ #+options: ':t toc:nil author:t email:t num:t #+startup: content -#+macro: stable-version 1.6.0 -#+macro: release-date 2021-09-29 -#+macro: development-version 1.7.0-dev +#+macro: stable-version 1.7.0 +#+macro: release-date 2021-11-18 +#+macro: development-version 1.8.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -95,7 +95,7 @@ Emacs. :end: #+cindex: Screenshots -Check the web page with [[https://protesilaos.com/modus-themes-pictures/][the screen shots]]. There are lots of scenarios +Check the web page with [[https://protesilaos.com/emacs/modus-themes-pictures/][the screen shots]]. There are lots of scenarios on display that draw attention to details and important aspects in the design of the themes. They also showcase the numerous customization options. @@ -108,7 +108,7 @@ options. :end: #+cindex: Changelog -Please refer to the [[https://protesilaos.com/modus-themes-changelog][web page with the change log]]. It is comprehensive +Please refer to the [[https://protesilaos.com/emacs/modus-themes-changelog][web page with the change log]]. It is comprehensive and covers everything that goes into every tagged release of the themes. * Installation @@ -268,7 +268,7 @@ could look like: (define-key global-map (kbd "") #'modus-themes-toggle) #+end_src -[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration for use-package]]. +[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]]. With those granted, bear in mind a couple of technical points on ~modus-themes-load-operandi~ and ~modus-themes-load-vivendi~, as well as @@ -283,11 +283,12 @@ With those granted, bear in mind a couple of technical points on wish to rely on such a hook and the functions that run it: they may prefer a custom solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). -** Sample configuration for use-package +** Sample configuration with and without use-package :properties: :custom_id: h:e979734c-a9e1-4373-9365-0f2cd36107b8 :end: #+cindex: use-package configuration +#+cindex: sample configuration It is common for Emacs users to rely on ~use-package~ for declaring package configurations in their setup. We use this as an example: @@ -309,6 +310,25 @@ package configurations in their setup. We use this as an example: :bind ("" . modus-themes-toggle)) #+end_src +The same without ~use-package~: + +#+begin_src emacs-lisp +(require 'modus-themes) + +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + +;; Load the theme files before enabling a theme +(modus-themes-load-themes) + +;; Load the theme of your choice: +(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi) + +(define-key global-map (kbd "") #'modus-themes-toggle) +#+end_src + [[#h:e68560b3-7fb0-42bc-a151-e015948f8a35][Differences between loading and enabling]]. Note: make sure not to customize the variable ~custom-theme-load-path~ @@ -325,7 +345,7 @@ package declaration of the themes. The reason we recommend ~load-theme~ instead of the other option of ~enable-theme~ is that the former does a kind of "reset" on the face -specs. It quite literally loads (or re-loads) the theme. Whereas the +specs. It quite literally loads (or reloads) the theme. Whereas the latter simply puts an already loaded theme at the top of the list of enabled items, re-using whatever state was last loaded. @@ -352,7 +372,7 @@ session, are better off using something like this: (enable-theme 'modus-operandi) ;; OR (enable-theme 'modus-vivendi) #+end_src -[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration for use-package]]. +[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]]. With the above granted, other sections of the manual discuss how to configure custom faces, where ~load-theme~ is expected, though @@ -372,7 +392,8 @@ without any further tweaks. By default, all customization options are set to nil, unless otherwise noted in this manual. Remember that all customization options must be evaluated before loading -a theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). +a theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). If the theme is already active, it must be +reloaded for changes in user options to come into force. Below is a summary of what you will learn in the subsequent sections of this manual. @@ -380,8 +401,9 @@ this manual. #+begin_src emacs-lisp (setq modus-themes-italic-constructs t modus-themes-bold-constructs nil - modus-themes-no-mixed-fonts nil + modus-themes-mixed-fonts nil modus-themes-subtle-line-numbers nil + modus-themes-intense-markup t modus-themes-success-deuteranopia t modus-themes-tabs-accented t modus-themes-inhibit-reload t ; only applies to `customize-set-variable' and related @@ -391,7 +413,7 @@ this manual. ;; Options for `modus-themes-lang-checkers' are either nil (the ;; default), or a list of properties that may include any of those ;; symbols: `straight-underline', `text-also', `background', - ;; `intense' + ;; `intense' OR `faint'. modus-themes-lang-checkers nil ;; Options for `modus-themes-mode-line' are either nil, or a list @@ -399,6 +421,10 @@ this manual. ;; `accented', `padded'. modus-themes-mode-line '(padded accented borderless) + ;; This one only works when `modus-themes-mode-line' (above) has + ;; the `padded' property. It takes a positive integer. + modus-themes-mode-line-padding 3 + ;; Options for `modus-themes-syntax' are either nil (the default), ;; or a list of properties that may include any of those symbols: ;; `faint', `yellow-comments', `green-strings', `alt-syntax' @@ -450,7 +476,7 @@ this manual. modus-themes-headings ; this is an alist: read the manual or its doc string '((1 . (overline background)) (2 . (rainbow overline)) - (t . (no-bold))) + (t . (semibold))) modus-themes-variable-pitch-ui nil modus-themes-variable-pitch-headings t @@ -470,7 +496,10 @@ this manual. :end: #+vindex: modus-themes-inhibit-reload -Symbol: ~modus-themes-inhibit-reload~ +Brief: Toggle reloading of the active theme when an option is changed +through the Customize UI. + +Symbol: ~modus-themes-inhibit-reload~ (=boolean= type) Possible values: @@ -483,6 +512,9 @@ currently active Modus theme. Enable this behaviour by setting this variable to ~nil~. +Regardless of this option, the active theme must be reloaded for changes +to user options to take effect ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). + ** Option for color-coding success state (deuteranopia) :properties: :alt_title: Success' color-code @@ -491,25 +523,27 @@ Enable this behaviour by setting this variable to ~nil~. :end: #+vindex: modus-themes-success-deuteranopia -Symbol: ~modus-themes-success-deuteranopia~ +Brief: Toggle the use of blue instead of green in places which +color-code green as "success" and red as "failure". + +Symbol: ~modus-themes-success-deuteranopia~ (=boolean= type) Possible values: 1. ~nil~ (default) 2. ~t~ -The default is to colorise all faces that denote "success", "done", or -similar with a variant of green. +The default is to colorise a passing state in a green hue. This affects +all faces that denote "success", "done", marking a selection as opposed +to marking for deletion, the current search match in contrast to lazily +highlighted ones, and the like. With a non-nil value (~t~), use variants of blue instead of green. This is meant to empower users with red-green color deficiency. -The present customization option should apply to all contexts where -there can be a color-coded distinction between success and failure, -to-do and done, and so on. - -Diffs, which have a red/green dichotomy by default, can also be -configured to conform with deuteranopia. +Diffs, which rely on a red/green dichotomy by default, can also be +configured to meet the needs of users with deuteranopia via the option +~modus-themes-diffs~. [[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]]. @@ -521,7 +555,9 @@ configured to conform with deuteranopia. :end: #+vindex: modus-themes-bold-constructs -Symbol: ~modus-themes-bold-constructs~ +Brief: Use bold for code syntax highlighting and related. + +Symbol: ~modus-themes-bold-constructs~ (=boolean= type) Possible values: @@ -549,7 +585,9 @@ Advanced users may also want to configure the exact attributes of the :end: #+vindex: modus-themes-italic-constructs -Symbol: ~modus-themes-italic-constructs~ +Brief: Use italics for code syntax highlighting and related. + +Symbol: ~modus-themes-italic-constructs~ (=boolean= type) Possible values: @@ -575,7 +613,9 @@ Advanced users may also want to configure the exact attributes of the :end: #+vindex: modus-themes-syntax -Symbol: ~modus-themes-syntax~ +Brief: Set the overall style of code syntax highlighting. + +Symbol: ~modus-themes-syntax~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -629,36 +669,41 @@ weight or italic text: ~modus-themes-bold-constructs~ and [[#h:977c900d-0d6d-4dbb-82d9-c2aae69543d6][Option for more italic constructs]]. -** Option for no font mixing +** Option for font mixing :properties: -:alt_title: No mixed fonts +:alt_title: Mixed fonts :description: Toggle mixing of font families :custom_id: h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b :end: -#+vindex: modus-themes-no-mixed-fonts +#+vindex: modus-themes-mixed-fonts -Symbol: ~modus-themes-no-mixed-fonts~ +Brief: Toggle the use of monospaced fonts for spacing-sensitive +constructs (affects font families). + +Symbol: ~modus-themes-mixed-fonts~ (=boolean= type) Possible values: 1. ~nil~ (default) 2. ~t~ -By default, the themes configure some spacing-sensitive faces like Org +When set to non-nil (~t~), configure some spacing-sensitive faces like Org tables and code blocks to always inherit from the ~fixed-pitch~ face. -This is to ensure that those constructs remain monospaced even when -users opt for a mode that remaps typeface families, such as the built-in -{{{kbd(M-x variable-pitch-mode)}}}. Otherwise the layout would appear -broken, due to how spacing is done. To disable this behaviour, set the -option to ~t~. +This is to ensure that certain constructs like code blocks and tables +remain monospaced even when users opt for a mode that remaps typeface +families, such as the built-in {{{kbd(M-x variable-pitch-mode)}}}. Otherwise +the layout would appear broken, due to how spacing is done. -Users may prefer to use another package for handling mixed typeface -configurations, rather than letting the theme do it, perhaps because a -purpose-specific package has extra functionality. Two possible options -are ~org-variable-pitch~ and ~mixed-pitch~. +For a consistent experience, user may need to specify the font family of +the ~fixed-pitch~ face. [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. +Furthermore, users may prefer to use another package for handling mixed +typeface configurations, rather than letting the theme do it, perhaps +because a purpose-specific package has extra functionality. Two +possible options are ~org-variable-pitch~ and ~mixed-pitch~. + ** Option for links :properties: :alt_title: Link styles @@ -667,7 +712,9 @@ are ~org-variable-pitch~ and ~mixed-pitch~. :end: #+vindex: modus-themes-links -Symbol: ~modus-themes-links~ +Brief: Control the style of links to web pages, files, buffers... + +Symbol: ~modus-themes-links~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -738,7 +785,10 @@ their documentation strings. :end: #+vindex: modus-themes-prompts -Symbol: ~modus-themes-prompts~ +Brief: Control the style of command prompts (e.g. minibuffer, shell, IRC +clients). + +Symbol: ~modus-themes-prompts~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -794,7 +844,9 @@ In user configuration files the form may look like this: :end: #+vindex: modus-themes-mode-line -Symbol: ~modus-themes-mode-line~ +Brief: Control the style of the mode lines. + +Symbol: ~modus-themes-mode-line~ (=choice= type, list of properties) Possible values, which can be expressed as a list of combinations of box effect, color, and border visibility: @@ -836,7 +888,10 @@ This is done by applying box effects and combining them with an underline and overline. To ensure that the underline is placed at the bottom, set ~x-underline-at-descent-line~ to non-nil. The ~padded~ property has no effect when the ~moody~ property is also used, because Moody -already applies its own padding. +already applies its own padding. The exact value of the padding is +controlled by the variable ~modus-themes-mode-line-padding~. + +[[#h:a12b4d3c-e66b-42ed-99ab-4ea039b69e2e][Option for mode line padding]]. Combinations of any of those properties are expressed as a list, like in these examples: @@ -877,6 +932,28 @@ Furthermore, because Moody expects an underline and overline instead of a box style, it is advised to set ~x-underline-at-descent-line~ to a non-nil value. +Finally, note that various packages which heavily modify the mode line, +such as =doom-modeline=, =nano-modeline=, =powerline=, =spaceline= may not look +as intended with all possible combinations of this user option. + +*** Option for mode line padding +:properties: +:custom_id: h:a12b4d3c-e66b-42ed-99ab-4ea039b69e2e +:end: +#+vindex: modus-themes-mode-line-padding + +Brief: Set the padding of the mode lines. + +Symbol: ~modus-themes-mode-line-padding~ (=natnum= type) + +Controls the exact width of the mode line's padding. Possible values +are positive integers. The default value is =6=. + +This customization option applies only when ~modus-themes-mode-line~ is +configured with the ~padded~ property. + +[[#h:27943af6-d950-42d0-bc23-106e43f50a24][Option for mode line presentation]]. + ** Option for accented background in tab interfaces :properties: :alt_title: Tab style @@ -885,7 +962,9 @@ non-nil value. :end: #+vindex: modus-themes-tabs-accented -Symbol: ~modus-themes-tabs-accented~ +Brief: Toggle accent colors for tabbed interfaces. + +Symbol: ~modus-themes-tabs-accented~ (=boolean= type) Possible values: @@ -906,7 +985,9 @@ Centaur tabs package. :end: #+vindex: modus-themes-completions -Symbol: ~modus-themes-completions~ +Brief: Set the overall style of completion framework interfaces. + +Symbol: ~modus-themes-completions~ (=choice= type) Possible values: @@ -951,7 +1032,10 @@ possibilities. :end: #+vindex: modus-themes-mail-citations -Symbol: ~modus-themes-mail-citations~ +Brief: Set the overall style of citations/quotes when composing +emails. + +Symbol: ~modus-themes-mail-citations~ (=choice= type) Possible values: @@ -980,7 +1064,9 @@ not touch. :end: #+vindex: modus-themes-fringes -Symbol: ~modus-themes-fringes~ +Brief: Control the overall coloration of the fringes. + +Symbol: ~modus-themes-fringes~ (=choice= type) Possible values: @@ -1004,7 +1090,10 @@ names imply. :end: #+vindex: modus-themes-lang-checkers -Symbol: ~modus-themes-lang-checkers~ +Brief: Control the style of in-buffer warnings and errors produced by +spell checkers, code linters, and the like. + +Symbol: ~modus-themes-lang-checkers~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1012,7 +1101,9 @@ an empty list). The list can include any of the following symbols: + ~straight-underline~ + ~text-also~ + ~background~ -+ ~intense~ ++ Overall coloration: + - ~intense~ + - ~faint~ The default (a ~nil~ value or an empty list) applies a color-coded underline to the affected text, while it leaves the original foreground @@ -1028,15 +1119,15 @@ affected text. The property ~background~ adds a color-coded background. The property ~intense~ amplifies the applicable colors if ~background~ -and/or ~text-only~ are set. If ~intense~ is set on its own, then it implies -~text-only~. +and/or ~text-also~ are set. If ~intense~ is set on its own, then it implies +~text-also~. -To disable fringe indicators for Flymake or Flycheck, refer to variables -~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~, -respectively. +The property ~faint~ uses nuanced colors for the underline and for the +foreground when ~text-also~ is included. If both ~faint~ and ~intense~ are +specified, the former takes precedence. -Combinations of any of those properties can be expressed in a -list, as in those examples: +Combinations of any of those properties can be expressed in a list, as +in those examples: #+begin_src emacs-lisp (background) @@ -1056,6 +1147,10 @@ NOTE: The placement of the straight underline, though not the wave style, is controlled by the built-in variables ~underline-minimum-offset~, ~x-underline-at-descent-line~, ~x-use-underline-position-properties~. +To disable fringe indicators for Flymake or Flycheck, refer to variables +~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~, +respectively. + ** Option for line highlighting (hl-line-mode) :properties: :alt_title: Line highlighting @@ -1064,7 +1159,9 @@ style, is controlled by the built-in variables ~underline-minimum-offset~, :end: #+vindex: modus-themes-hl-line -Symbol: ~modus-themes-hl-line~ +Brief: Control the style of the current line of ~hl-line-mode~. + +Symbol: ~modus-themes-hl-line~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1116,7 +1213,9 @@ This style affects several packages that enable ~hl-line-mode~, such as :end: #+vindex: modus-themes-subtle-line-numbers -Symbol: ~modus-themes-subtle-line-numbers~ +Brief: Toggle subtle line numbers. + +Symbol: ~modus-themes-subtle-line-numbers~ (=boolean= type) Possible value: @@ -1137,6 +1236,30 @@ Instead they retain the primary background of the theme, blending with the rest of the buffer. Foreground values for all relevant faces are updated to accommodate this aesthetic. +** Option for intense markup in Org and others +:properties: +:alt_title: Intense markup +:description: Toggle intense style for markup in Org and others +:custom_id: h:9d9a4e64-99ac-4018-8f66-3051b9c43fd7 +:end: +#+vindex: modus-themes-intense-markup + +Brief: Toggle intense style for inline code and related markup. + +Symbol: ~modus-themes-intense-markup~ (=boolean= type) + +Possible value: + +1. ~nil~ (default) +2. ~t~ + +The default style for certain markup types like inline code and verbatim +constructs in Org and related major modes is a subtle foreground color +combined with a subtle background. + +With a non-nil value (~t~), these constructs will use a more prominent +background and foreground color combination instead. + ** Option for parenthesis matching (show-paren-mode) :properties: :alt_title: Matching parentheses @@ -1145,7 +1268,10 @@ updated to accommodate this aesthetic. :end: #+vindex: modus-themes-paren-match -Symbol: ~modus-themes-paren-match~ +Brief: Control the style of matching delimiters produced by +~show-paren-mode~. + +Symbol: ~modus-themes-paren-match~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1192,7 +1318,9 @@ This customization variable affects the built-in ~show-paren-mode~ and the :end: #+vindex: modus-themes-region -Symbol: ~modus-themes-region~ +Brief: Control the style of the region. + +Symbol: ~modus-themes-region~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1238,7 +1366,9 @@ In user configuration files the form may look like this: :end: #+vindex: modus-themes-diffs -Symbol: ~modus-themes-diffs~ +Bried: Set the overall style of diffs. + +Symbol: ~modus-themes-diffs~ (=choice= type) Possible values: @@ -1284,7 +1414,9 @@ interest of backward compatibility. :end: #+vindex: modus-themes-org-blocks -Symbol: ~modus-themes-org-blocks~ +Brief: Set the overall style of Org code blocks, quotes, and the like. + +Symbol: ~modus-themes-org-blocks~ (=choice= type) Possible values: @@ -1325,7 +1457,10 @@ and ~rainbow~. Those will continue to work as they are aliases for :end: #+vindex: modus-themes-org-agenda -Symbol: ~modus-themes-org-agenda~ +Brief: Control the style of the Org agenda. Multiple parameters are +available, each with its own options. + +Symbol: ~modus-themes-org-agenda~ (=alist= type, multiple styles) This is an alist that accepts a =(key . value)= combination. Some values are specified as a list. Here is a sample, followed by a description of @@ -1335,7 +1470,7 @@ all possible combinations: (setq modus-themes-org-agenda '((header-block . (variable-pitch scale-title)) (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + (event . (accented italic varied)) (scheduled . uniform) (habit . traffic-light))) #+end_src @@ -1394,28 +1529,41 @@ For example: (header-date . (grayscale workaholic bold-today scale-heading)) #+end_src -An ~event~ key covers events from the diary and other entries that derive -from a symbolic expression or sexp (e.g. phases of the moon, holidays). -This key accepts a list of values. By default (a nil value or an empty -list) those have a gray foreground, while sexp events are additionally -presented using slanted text (italics). The properties that can form a -list of possible values are: +An ~event~ key covers (i) headings with a plain time stamp that are +shown on the agenda, also known as events, (ii) entries imported from +the diary, and (iii) other items that derive from a symbolic expression +or sexp (phases of the moon, holidays, etc.). By default all those look +the same and have a subtle foreground color (the default is a nil value +or an empty list). This key accepts a list of properties. Those are: -- ~scale-small~ reduces the height of the entries to the value of the user - option ~modus-themes-scale-small~ (0.9 the height of the main font size - by default). -- ~accented~ applies an accent value to the event's foreground, replacing - the original gray. +- ~scale-small~ reduces the height of the entries to the value of + the user option ~modus-themes-scale-small~ (0.9 the height of + the main font size by default). This work best when the + relevant entries have no tags associated with them and when the + user is interested in reducing their presence in the agenda + view. +- ~accented~ applies an accent value to the event's foreground, + replacing the original gray. It makes all entries stand out more. - ~italic~ adds a slant to the font's forms (italic or oblique forms, depending on the typeface). +- ~varied~ differentiates between events with a plain time stamp and + entries that are generated from either the diary or a symbolic + expression. It generally puts more emphasis on events. When ~varied~ + is combined with ~accented~, it makes only events use an accent color, + while diary/sexp entries retain their original subtle foreground. + When ~varied~ is used in tandem with ~italic~, it applies a slant only + to diary and sexp entries, not events. And when ~varied~ is the sole + property passed to the ~event~ key, it has the same meaning as the + list (italic varied). The combination of ~varied~, ~accented~, + ~italic~ covers all of the aforementioned cases. For example: #+begin_src emacs-lisp (event . nil) -(event . (scale-small)) -(event . (scale-small accented)) -(event . (scale-small accented italic)) +(event . (italic)) +(event . (accented italic)) +(event . (accented italic varied)) #+end_src A ~scheduled~ key applies to tasks with a scheduled date. By default (a @@ -1498,7 +1646,10 @@ Putting it all together, the alist can look like this: :end: #+vindex: modus-themes-headings -Symbol: ~modus-themes-headings~ +Brief: Control the style of headings. This can be particularised for +each level of heading (e.g. Org has eight levels). + +Symbol: ~modus-themes-headings~ (=alist= type, multiple properties) This is an alist that accepts a =(key . list-of-values)= combination. The key is either a number, representing the heading's level or ~t~, which @@ -1518,8 +1669,21 @@ Properties: + ~rainbow~ + ~overline~ + ~background~ -+ ~no-bold~ + ~monochrome~ ++ A font weight, which must be supported by the underlying typeface: + - ~thin~ + - ~ultralight~ + - ~extralight~ + - ~light~ + - ~semilight~ + - ~regular~ + - ~medium~ + - ~semibold~ + - ~bold~ + - ~heavy~ + - ~extrabold~ + - ~ultrabold~ ++ ~no-bold~ By default (a ~nil~ value for this variable), all headings have a bold typographic weight and use a desaturated text color. @@ -1531,20 +1695,27 @@ An ~overline~ property draws a line above the area of the heading. A ~background~ property adds a subtle tinted color to the background of the heading. -A ~no-bold~ property removes the bold weight from the heading's text. - A ~monochrome~ property makes all headings the same base color, which is that of the default for the active theme (black/white). When ~background~ is also set, ~monochrome~ changes its color to gray. If both ~monochrome~ and ~rainbow~ are set, the former takes precedence. +The symbol of a weight attribute adjusts the font of the heading +accordingly, such as ~light~, ~semibold~, etc. Valid symbols are defined in +the internal variable ~modus-themes--heading-weights~. The absence of a +weight means that bold will be used by virtue of inheriting the ~bold~ +face. For backward compatibility, the ~no-bold~ value is accepted, though +users are encouraged to specify a ~regular~ weight instead. + +[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]]. + Combinations of any of those properties are expressed as a list, like in these examples: #+begin_src emacs-lisp -(no-bold) +(semibold) (rainbow background) -(overline monochrome no-bold) +(overline monochrome semibold) #+end_src The order in which the properties are set is not significant. @@ -1555,7 +1726,7 @@ In user configuration files the form may look like this: (setq modus-themes-headings '((1 . (background overline rainbow)) (2 . (background overline)) - (t . (overline no-bold)))) + (t . (overline semibold)))) #+end_src When defining the styles per heading level, it is possible to pass a @@ -1570,7 +1741,7 @@ original aesthetic for that level. For example: (setq modus-themes-headings '((1 . (background overline)) - (2 . (rainbow no-bold)) + (2 . (rainbow semibold)) (t . t))) ; default style for all other levels #+end_src @@ -1591,7 +1762,9 @@ others, such as ~org-fontify-done-headline~. :end: #+vindex: modus-themes-scale-headings -Symbol: ~modus-themes-scale-headings~ +Brief: Toggle the scaling of headings. + +Symbol: ~modus-themes-scale-headings~ (=boolean= type) Possible values: @@ -1610,6 +1783,17 @@ main text. This is noticeable in modes like Org, Markdown, and Info. :custom_id: h:6868baa1-beba-45ed-baa5-5fd68322ccb3 :end: +Brief: Specify the height for individual heading scales. + +Symbols (all are =number= type): + ++ ~modus-themes-scale-1~ ++ ~modus-themes-scale-2~ ++ ~modus-themes-scale-3~ ++ ~modus-themes-scale-4~ ++ ~modus-themes-scale-title~ ++ ~modus-themes-scale-small~ + In addition to the toggle for enabling scaled headings, users can also specify a number of their own. @@ -1681,7 +1865,10 @@ size of the heading, but not of keywords that were added to it, like :end: #+vindex: modus-themes-variable-pitch-ui -Symbol: ~modus-themes-variable-pitch-ui~ +Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts +in the User Interface. + +Symbol: ~modus-themes-variable-pitch-ui~ (=boolean= type) Possible values: @@ -1708,7 +1895,10 @@ is done by assigning the ~variable-pitch~ face to the relevant items. :end: #+vindex: modus-themes-variable-pitch-headings -Symbol: ~modus-themes-variable-pitch-headings~ +Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts +in headings. + +Symbol: ~modus-themes-variable-pitch-headings~ (=boolean= type) Possible values: @@ -2460,17 +2650,16 @@ inspiration from the ~modus-themes-toggle~ we already provide: :end: #+cindex: Font configurations -The themes are designed to cope well with mixed font configurations. +The themes are designed to optionally cope well with mixed font +configurations. This mostly concerns ~org-mode~ and ~markdown-mode~, though +expect to find it elsewhere like in ~Info-mode~. -[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for no font mixing]]. - -This mostly concerns ~org-mode~ and ~markdown-mode~, though expect to find -it elsewhere like in ~Info-mode~. +[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for font mixing]]. In practice it means that the user can safely opt for a more prose-friendly proportionately spaced typeface as their default, while -letting spacing-sensitive elements like tables and inline code always -use a monospaced font, by inheriting from the ~fixed-pitch~ face. +spacing-sensitive elements like tables and inline code always use a +monospaced font, by inheriting from the ~fixed-pitch~ face. Users can try the built-in {{{kbd(M-x variable-pitch-mode)}}} to see the effect in action. @@ -2491,7 +2680,14 @@ reading the doc string of ~set-face-attribute~): (set-face-attribute 'variable-pitch nil :family "DejaVu Serif" :height 1.0) ;; Monospaced typeface -(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.0) +(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.5) +#+end_src + +Or employ the ~face-attribute~ function to read an existing value, such as +if you want to make ~fixed-pitch~ use the font family of the ~default~ face: + +#+begin_src emacs-lisp +(set-face-attribute 'fixed-pitch nil :family (face-attribute 'default :family)) #+end_src The next section shows how to make those work in a more elaborate setup @@ -2504,12 +2700,13 @@ specify an absolute value, which is the point size × 10. So if you want to use a font at point size =11=, you set the height to =110=.[fn:: ~:height~ values do not need to be rounded to multiples of ten: the likes of =115= are perfectly valid—some typefaces will change to account for those -finer increments.] Whereas every other face must have a value that is -relative to the default, represented as a floating point (if you use an -integer, then that means an absolute height). This is of paramount -importance: it ensures that all fonts can scale gracefully when using -something like the ~text-scale-adjust~ command which only operates on the -base font size (i.e. the ~default~ face's absolute height). +finer increments.] Whereas every other face must either not specify a +height or have a value that is relative to the default, represented as a +floating point. If you use an integer, then that means an absolute +height. This is of paramount importance: it ensures that all fonts can +scale gracefully when using something like the ~text-scale-adjust~ command +which only operates on the base font size (i.e. the ~default~ face's +absolute height). [[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts (SHR fonts)]]. @@ -2545,7 +2742,7 @@ it means for a construct to be bold/italic, by tweaking the ~bold~ and To achieve those effects, one must first be sure that the fonts they use have support for those features. It then is a matter of following the -instructions for all face tweaks. +instructions for all typeface tweaks. [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. @@ -2573,19 +2770,20 @@ To reset the font family, one can use this: To ensure that the effects persist after switching between the Modus themes (such as with {{{kbd(M-x modus-themes-toggle)}}}), the user needs to -write their configurations to a function and hook it up to the -~modus-themes-after-load-theme-hook~. This is necessary because the -themes set the default styles of faces (otherwise changing themes would -not be possible). +write their configurations to a function and pass it to the +~modus-themes-after-load-theme-hook~. This is necessary because themes +set the styles of faces upon activation, overriding prior values where +conflicts occur between the previous and the current states (otherwise +changing themes would not be possible). [[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]. This is a minimal setup to preserve font configurations across theme -load phases. For a more permanent setup, it is better to employ the +load phases. For a more permanent setup, it is better to rely on the ~custom-set-faces~ function: ~set-face-attribute~ works just fine, though it -is more convenient for quick previews or for smaller scale operations -(~custom-set-faces~ follows the format used in the source code of the -themes). +probably is better suited for quick previews or for smaller scale +operations (~custom-set-faces~ follows the format used in the source code +of the themes, which can make it easier to redefine faces in bulk). #+begin_src emacs-lisp ;; our generic function @@ -2605,6 +2803,8 @@ themes). (add-hook 'modus-themes-after-load-theme-hook #'my-modes-themes-bold-italic-faces) #+end_src +[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. + ** Custom Org user faces (DIY) :properties: :custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad @@ -2897,6 +3097,101 @@ With those in place, PDFs have a distinct backdrop for their page, while they automatically switch to their dark mode when ~modus-themes-toggle~ is called from inside a buffer whose major-mode is ~pdf-view-mode~. +** Decrease mode line height (DIY) +:properties: +:custom_id: h:03be4438-dae1-4961-9596-60a307c070b5 +:end: +#+cindex: Decrease mode line height + +By default, the mode line of the Modus themes is set to 1 pixel width +for its =:box= attribute. In contrast, the mode line of stock Emacs is -1 +pixel. This small difference is considered necessary for the purposes +of accessibility as our out-of-the-box design has a prominent color +around the mode line (a border) to make its boundaries clear. With a +negative width the border and the text on the mode line can feel a bit +more difficult to read under certain scenaria. + +Furthermore, the user option ~modus-themes-mode-line~ ([[#h:27943af6-d950-42d0-bc23-106e43f50a24][Mode line]]) does not +allow for such a negative value because there are many edge cases that +simply make for a counter-intuitive set of possibilities, such as a =0= +value not being acceptable by the underlying face infrastructure, and +negative values greater than =-2= not being particularly usable. + +For these reasons, users who wish to decrease the overall height of the +mode line must handle things on their own by implementing the methods +for face customization documented herein. + +[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Basic face customization]]. + +One such method is to create a function that configures the desired +faces and hook it to ~modus-themes-after-load-theme-hook~ so that it +persists while switching between the Modus themes with the command +~modus-themes-toggle~. + +This one simply disables the box altogether, which will reduce the +height of the mode lines, but also remove their border: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (set-face-attribute 'mode-line nil :box nil) + (set-face-attribute 'mode-line-inactive nil :box nil)) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +The above relies on the ~set-face-attribute~ function, though users who +plan to re-use colors from the theme and do so at scale are better off +with the more streamlined combination of the ~modus-themes-with-colors~ +macro and ~custom-set-faces~. + +[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face customization at scale]]. + +As explained before in this document, this approach has a syntax that is +consistent with the source code of the themes, so it probably is easier +to re-use parts of the design. + +The following emulates the stock Emacs style, while still using the +colors of the Modus themes (whichever attribute is not explicitly stated +is inherited from the underlying theme): + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(mode-line ((,class :box (:line-width -1 :style released-button)))) + `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region))))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +And this one is like the out-of-the-box style of the Modus themes, but +with the -1 height instead of 1: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(mode-line ((,class :box (:line-width -1 :color ,fg-alt)))) + `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region))))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +Finally, to also change the background color of the active mode line, +such as that it looks like the "accented" variant which is possible via +the user option ~modus-themes-mode-line~, the =:background= attribute needs +to be specified as well: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(mode-line ((,class :box (:line-width -1 :color ,fg-alt) :background ,bg-active-accent))) + `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region))))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + ** A theme-agnostic hook for theme loading (DIY) :properties: :custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 @@ -3121,6 +3416,7 @@ have lots of extensions, so the "full support" may not be 100% true… + ido-mode + iedit + iflipb ++ image-dired + imenu-list + indium + info @@ -3162,6 +3458,7 @@ have lots of extensions, so the "full support" may not be 100% true… + mu4e + mu4e-conversation + multiple-cursors ++ nano-modeline + neotree + no-emoji + notmuch @@ -3263,6 +3560,7 @@ have lots of extensions, so the "full support" may not be 100% true… + vc-annotate (the output of {{{kbd(C-x v g)}}}) + vdiff + vertico ++ vertico-quick + vimish-fold + visible-mark + visual-regexp @@ -3314,7 +3612,6 @@ supported by the themes. + tide + vertico-indexed + vertico-mouse -+ vertico-quick * Notes on individual packages :properties: @@ -4219,7 +4516,7 @@ The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/] being. A [[https://github.com/protesilaos/modus-themes/][mirror on Github]] is also on offer. An HTML version of this manual is provided as an extension of the -[[https://protesilaos.com/modus-themes/][author's personal website]] (does not rely on any non-free code). +[[https://protesilaos.com/emacs/modus-themes/][author's personal website]] (does not rely on any non-free code). ** Issues you can help with :properties: @@ -4323,11 +4620,11 @@ The Modus themes are a collective effort. Every bit of work matters. + Author/maintainer :: Protesilaos Stavrou. + Contributions to code or documentation :: Anders Johansson, Basil - L.{{{space()}}} Contovounesios, Carlo Zancanaro, Eli Zaretskii, Fritz Grabo, - Kévin Le Gouguec, Kostadin Ninev, Madhavan Krishnan, Markus Beppler, - Matthew Stevenson, Mauro Aranda, Nicolas De Jaeghere, Philip - Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan - Kangas, Vincent Murphy, Xinglu Chen. + L.{{{space()}}} Contovounesios, Carlo Zancanaro, Christian Tietze, Daniel + Mendler, Eli Zaretskii, Fritz Grabo, Kévin Le Gouguec, Kostadin Ninev, + Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, + Nicolas De Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen + Gildea, Shreyas Ragavan, Stefan Kangas, Vincent Murphy, Xinglu Chen. + Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers, Adrian Manea, Alex Griffin, Alex Peitsinis, Alexey Shmalko, Alok @@ -4336,19 +4633,20 @@ The Modus themes are a collective effort. Every bit of work matters. Dimech, Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David Edmondson, Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele Michele Alberto Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, Gerry - Agbobada, Gianluca Recchia, Gustavo Barros, Hörmetjan Yiltiz, Ilja - Kocken, Iris Garcia, Jeremy Friesen, Jerry Zhang, John Haman, Joshua - O'Connor, Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg, - Manuel Uberti, Mark Burton, Markus Beppler, Mauro Aranda, Michael - Goldenberg, Morgan Smith, Murilo Pereira, Nicky van Foreest, Nicolas - De Jaeghere, Paul Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, - Philip Kaludercic, Pierre Téchoueyres, Roman Rudakov, Ryan Phillips, - Rudolf Adamkovič, Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo - Horn, Thibaut Verron, Thomas Heartman, Trey Merkley, Togan Muftuoglu, - Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As well as - users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, - Moesasji, Nick, TheBlob42, Trey, bepolymathe, doolio, fleimgruber, - iSeeU, jixiuf, okamsn, pRot0ta1p. + Agbobada, Gianluca Recchia, Guilherme Semente, Gustavo Barros, + Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry + Zhang, Johannes Grødem, John Haman, Joshua O'Connor, Kevin Fleming, + Kévin Le Gouguec, Kostadin Ninev, Len Trigg, Manuel Uberti, Mark + Burton, Markus Beppler, Mauro Aranda, Michael Goldenberg, Morgan + Smith, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Paul + Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic, + Pierre Téchoueyres, Roman Rudakov, Ryan Phillips, Rudolf Adamkovič, + Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, Thibaut + Verron, Thomas Heartman, Trey Merkley, Togan Muftuoglu, Toon Claes, + Uri Sharf, Utkarsh Singh, Vincent Foley. As well as users: Ben, + CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, Moesasji, + Nick, TheBlob42, Trey, bepolymathe, doolio, fleimgruber, iSeeU, + jixiuf, okamsn, pRot0ta1p. + Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs), @@ -4358,9 +4656,10 @@ The Modus themes are a collective effort. Every bit of work matters. + Inspiration for certain features :: Bozhidar Batsov (zenburn-theme), Fabrice Niessen (leuven-theme). -Special thanks, in no particular order, to Manuel Uberti, Gustavo -Barros, and Omar Antolín Camarena for their long time contributions and -insightful commentary. +Special thanks (from A-Z) to Gustavo Barros, Manuel Uberti, Nicolas De +Jaeghere, and Omar Antolín Camarena for their long time contributions +and insightful commentary on key aspects of the themes' design and/or +aspects of their functionality. * Meta :properties: @@ -4388,9 +4687,9 @@ of this sort): And here are the canonical sources of this project's documentation: -+ Manual :: -+ Change Log :: -+ Screenshots :: ++ Manual :: ++ Change Log :: ++ Screenshots :: * GNU Free Documentation License :properties: diff --git a/doc/misc/org.org b/doc/misc/org.org index df2724dd9c0..85117714ee9 100644 --- a/doc/misc/org.org +++ b/doc/misc/org.org @@ -10811,6 +10811,18 @@ To turn off fontification for marked up text, you can set ~org-fontify-emphasized-text~ to ~nil~. To narrow down the list of available markup syntax, you can customize ~org-emphasis-alist~. +Sometimes, when marked text also contains the marker character itself, +the result may be unsettling. For example, + +#+begin_example +/One may expect this whole sentence to be italicized, but the +following ~user/?variable~ contains =/= character, which effectively +stops emphasis there./ +#+end_example + +You can use zero width space to help Org sorting out the ambiguity. +See [[*Escape Character]] for more details. + ** Subscripts and Superscripts :PROPERTIES: :DESCRIPTION: Simple syntax for raising/lowering text. diff --git a/doc/misc/pcl-cvs.texi b/doc/misc/pcl-cvs.texi index 4ba067fd81f..833326c089b 100644 --- a/doc/misc/pcl-cvs.texi +++ b/doc/misc/pcl-cvs.texi @@ -524,8 +524,8 @@ you can use in PCL-CVS@. They are grouped together by type. Most commands in PCL-CVS require that you have a @file{*cvs*} buffer. The commands that you use to get one are listed below. For each, a @samp{cvs} process will be run, the output will be parsed by -PCL-CVS, and the result will be printed in the @file{*cvs*} buffer (see -@ref{Buffer contents}, for a description of the buffer's contents). +PCL-CVS, and the result will be printed in the @file{*cvs*} buffer +(@pxref{Buffer contents}, for a description of the buffer's contents). @table @kbd @item M-x cvs-update diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi index a4ca54a8b01..58ca045e786 100644 --- a/doc/misc/rcirc.texi +++ b/doc/misc/rcirc.texi @@ -609,12 +609,6 @@ Use this symbol if you need to identify yourself in the Bitlbee channel as follows: @code{identify secret}. The necessary arguments are the nickname you want to use this for, and the password to use. -@item sasl -@cindex sasl authentication -Use this symbol if you want to use @acronym{SASL} authentication. The -necessary arguments are the nickname you want to use this for, and the -password to use. - @cindex gateway to other IM services @cindex instant messaging, other services @cindex Jabber @@ -633,6 +627,19 @@ the other instant messaging services, and Bitlbee will log you in. All @code{rcirc} needs to know, is the login to your Bitlbee account. Don't confuse the Bitlbee account with all the other accounts. +@item sasl +@cindex sasl authentication +Use this symbol if you want to use @acronym{SASL} authentication. The +necessary arguments are the nickname you want to use this for, and the +password to use. + +@item certfp +@cindex certfp authentication +Use this symbol if you want to use CertFP authentication. The +necessary arguments are the path to the client certificate key and +password. The CertFP authentication requires a @acronym{TLS} +connection. + @end table @end table diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 819670a5088..1f6d4ad6269 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -3388,8 +3388,8 @@ returns the exit code for it. When the user option indication that the process has been interrupted, and returns a corresponding string. -This remote process handling does not apply to @acronym{GVFS} (see -@ref{GVFS-based methods}) because the remote file system is mounted on +This remote process handling does not apply to @acronym{GVFS} +(@pxref{GVFS-based methods}) because the remote file system is mounted on the local host and @value{tramp} accesses it by changing the @code{default-directory}. @@ -3410,7 +3410,7 @@ might also add their name to this environment variable, like For @value{tramp} to find the command on the remote, it must be accessible through the default search path as setup by @value{tramp} upon first connection. Alternatively, use an absolute path or extend -@code{tramp-remote-path} (see @ref{Remote programs}): +@code{tramp-remote-path} (@pxref{Remote programs}): @lisp @group @@ -5222,6 +5222,28 @@ time being you can suppress this error by the following code in your @end lisp +@item +I get an error @samp{Remote file error: Not a valid Tramp file name +function `tramp-FOO-file-name-p'} + +@value{tramp} has changed the signature of an internal function. +External packages implementing an own @value{tramp} backend must +follow this change. Please report this problem to the author of that +package. + +For the running session, @value{tramp} disables the external package, +and you can continue to work. If you don't want to see this error +while activating @value{tramp}, you can suppress it by the same code +as above in your @file{~/.emacs}: + +@lisp +@group +(setq debug-ignored-errors + (cons 'remote-file-error debug-ignored-errors)) +@end group +@end lisp + + @item How to disable other packages from calling @value{tramp}? diff --git a/doc/misc/vhdl-mode.texi b/doc/misc/vhdl-mode.texi index fef98a74636..7022582db51 100644 --- a/doc/misc/vhdl-mode.texi +++ b/doc/misc/vhdl-mode.texi @@ -243,7 +243,7 @@ components. Also notice that the first component, @vindex vhdl-offsets-alist @vindex offsets-alist @r{(vhdl-)} Indentation for the current line is calculated using the syntactic -component list derived in step 1 above (see @ref{Syntactic +component list derived in step 1 above (@pxref{Syntactic Analysis}). Each component contributes to the final total indentation of the line in two ways. @@ -668,7 +668,7 @@ not handled by the mode directly. @cindex custom indentation functions One of the most common ways to customize VHDL Mode is by writing @dfn{custom indentation functions} and associating them with specific -syntactic symbols (see @ref{Syntactic Symbols}). VHDL Mode itself +syntactic symbols (@pxref{Syntactic Symbols}). VHDL Mode itself uses custom indentation functions to provide more sophisticated indentation, for example when lining up selected signal assignments: @example @@ -732,7 +732,7 @@ operator on the first line of the statement. Here is the lisp code @end example @noindent Custom indent functions take a single argument, which is a syntactic -component cons cell (see @ref{Syntactic Analysis}). The +component cons cell (@pxref{Syntactic Analysis}). The function returns an integer offset value that will be added to the running total indentation for the line. Note that what actually gets returned is the difference between the column that the signal assignment diff --git a/etc/DEBUG b/etc/DEBUG index 555370588fe..a05aeef1606 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -591,9 +591,13 @@ If you cannot figure out the cause for the problem using the above, native-compile the problematic file after setting the variable 'comp-libgccjit-reproducer' to a non-nil value. That should produce a file named ELNFILENAME_libgccjit_repro.c, where ELNFILENAME is the -name of the problematic .eln file, in the same directory where the -.eln file is produced. Then attach that reproducer C file to your bug -report. +name of the problematic .eln file, either in the same directory where +the .eln file is produced, or under your ~/.emacs.d/eln-cache (which +one depends on how the native-compilation is invoked). It is also +possible that the reproducer file's name will be something like +subr--trampoline-XXXXXXX_FUNCTION_libgccjit_repro.c, where XXXXXXX is +a long string of hex digits and FUNCTION is some function from the +compiled .el file. Attach that reproducer C file to your bug report. ** Following longjmp call. diff --git a/etc/MACHINES b/etc/MACHINES index d8d0b86fb4d..d883f1abd60 100644 --- a/etc/MACHINES +++ b/etc/MACHINES @@ -103,6 +103,34 @@ the list at the end of this file. ./configure CC='gcc -m64' # GCC ./configure CC='cc -m64' # Oracle Developer Studio +** Haiku + + On 32-bit Haiku it is required that the newer GCC 8 be used, instead + of the legacy GCC 2 used by default. This can be achieved by + invoking configure inside a shell launched by the 'setarch' program + invoked as 'setarch x86'. + + When building with packages discovered through pkg-config, such as + libpng, on a GCC 2/GCC 8 hybrid system, simply evaluating 'setarch + x86' is insufficient to ensure that all required libraries are found + at their correct locations. To avoid this problem, set the + environment variable 'PKG_CONFIG_PATH' to the GCC 8 pkg-config + directory at '/system/develop/lib/x86/pkgconfig/' before configuring + Emacs. + + If GCC complains about not being able to resolve symbols such as + "BHandler::LockLooper", you are almost certainly experiencing this + problem. + + Haiku running on non-x86 systems has not been tested. It is + anticipated that Haiku running on big-endian systems will experience + problems when Emacs is built with Haiku windowing support, but there + doesn't seem to be any reliable way to get Haiku running on a + big-endian system at present. + + The earliest release of Haiku that will successfully compile Emacs + is R1/Beta2. For windowing support, R1/Beta3 or later is required. + * Obsolete platforms diff --git a/etc/NEWS b/etc/NEWS index c362e56ceeb..87a7a43a5ed 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -24,12 +24,41 @@ applies, and please also update docstrings as needed. * Installation Changes in Emacs 29.1 +** Emacs has been ported to the Haiku operating system. +The configuration process should automatically detect and build for +Haiku. There is also an optional window-system port to Haiku, which +can be enabled by configuring Emacs with the option '--with-be-app', +which will require the Haiku Application Kit development headers and a +C++ compiler to be present on your system. If Emacs is not built with +the option '--with-be-app', the resulting Emacs will only run in +text-mode terminals. + ++++ +*** Cairo drawing support has been enabled for Haiku builds. +To enable Cairo support, ensure that the Cairo and FreeType +development files are present on your system, and configure Emacs with +'--with-be-cairo'. + +--- +*** Double buffering is now enabled on the Haiku operating system. +Unlike X, there is no compile-time option to enable or disable +double-buffering. If you wish to disable double-buffering, change the +frame parameter `inhibit-double-buffering' instead. + ** Emacs now installs the ".pdmp" file using a unique fingerprint in the name. The file is typically installed using a file name akin to "...dir/libexec/emacs/29.1/x86_64-pc-linux-gnu/emacs-.pdmp". If a constant file name is required, the file can be renamed to "emacs.pdmp", and Emacs will find it during startup anyway. +** Emacs now supports use of XInput 2 for input events. +If your X server has support and you have the XInput 2 development headers +installed, you can configure Emacs with the option '--with-xinput2' to enable +this support. + +The named feature `xinput2' can be used to test for the presence of +XInput 2 support from Lisp programs. + * Startup Changes in Emacs 29.1 @@ -46,6 +75,38 @@ time. * Changes in Emacs 29.1 ++++ +** New face 'mode-line-active'. +This inherits from the 'mode-line' face, but is the face actually used +on the mode lines (along with 'mode-line-inactive'). + +--- +** The mode line now uses a proportional font by default. +To get the old monospaced mode line back, customize the +'mode-line-active' and 'mode-line-inactive' faces not to inherit from +the 'variable-pitch' face, or add this to your ~/.emacs: + + (set-face-attribute 'mode-line-active nil :inherit 'mode-line) + (set-face-attribute 'mode-line-inactive nil :inherit 'mode-line) + ++++ +** New function 'buffer-text-pixel-size'. +This is similar to 'window-text-pixel-size', but can be used when the +buffer isn't displayed. + ++++ +** New X resource: "borderThickness". +This controls the thickness of the external borders of the menu bars +and pop-up menus. + +--- +** New minor mode 'pixel-scroll-precision-mode'. +When enabled, and if your mouse supports it, you can scroll the +display up or down at pixel resolution, according to what your mouse +wheel reports. Unlike 'pixel-scroll-mode', this mode scrolls the +display pixel-by-pixel, as opposed to only animating line-by-line +scrolls. + ** Terminal Emacs --- @@ -54,6 +115,18 @@ This is in addition to previously-supported ways of discovering 24-bit color support: either via the "RGB" or "setf24" capabilities, or if the 'COLORTERM' environment variable is set to the value "truecolor". ++++ +** New ERT variables 'ert-batch-print-length' and 'ert-batch-print-level'. +These variables will override 'print-length' and 'print-level' when +printing Lisp values in ERT batch test results. + +--- +** Redefining an ERT test in batch mode now signals an error +Executing 'ert-deftest' with the same name as an existing test causes +the previous definition to be discarded, which was probably not +intended when this occurs in batch mode. To remedy the error, rename +tests so that they all have unique names. + ** Emoji +++ @@ -130,6 +203,11 @@ For example, a 'display-buffer-alist' entry of will make the body of the chosen window 40 columns wide. For the height use 'window-height' in combination with 'body-lines'. +** Tab Bars and Tab Lines + +--- +*** 'C-x t RET' creates a new tab when the provided tab name doesn't exist. + ** Better detection of text suspiciously reordered on display. The function 'bidi-find-overridden-directionality' has been extended to detect reordering effects produced by embeddings and isolates @@ -205,6 +283,15 @@ The user option 'comint-terminfo-terminal' and variable 'system-uses-terminfo' can now be set as connection-local variables to change the terminal used on a remote host. +** Mwheel + +--- +*** New user options for alternate wheel events. +The options 'mouse-wheel-down-alternate-event', 'mouse-wheel-up-alternate-event', +'mouse-wheel-left-alternate-event', and 'mouse-wheel-right-alternate-event' have +been added to better support systems where two kinds of wheel events can be +received. + * Changes in Specialized Modes and Packages in Emacs 29.1 @@ -261,6 +348,10 @@ the common "utm_" trackers from URLs. ** Gnus +--- +*** New face 'gnus-header'. +All other 'gnus-header-*' faces inherit from this face now. + +++ *** New user option 'gnus-treat-emojize-symbols'. If non-nil, symbols that have an emoji representation will be @@ -374,7 +465,7 @@ This works like 'image-transform-fit-to-window'. *** New user option 'image-auto-resize-max-scale-percent'. The new 'fit-window' option will never scale an image more than this -much (in percent). It is nil by default. +much (in percent). It is nil by default, which means no limit. ** Image-Dired @@ -474,6 +565,11 @@ This is a convenience function to extract the field data from Using this option you can control how the xwidget-webkit buffers are named. +--- +*** New user option 'xwidget-webkit-cookie-file'. +Using this option you can control whether the xwidget-webkit buffers +save cookies set by web pages, and if so, in which file to save them. + +++ *** New minor mode 'xwidget-webkit-edit-mode'. When this mode is enabled, self-inserting characters and other common @@ -482,10 +578,15 @@ WebKit widget. +++ *** New minor mode 'xwidget-webkit-isearch-mode'. -This mode acts similarly to incremental search, and allows to search +This mode acts similarly to incremental search, and allows searching the contents of a WebKit widget. In xwidget-webkit mode, it is bound to 'C-s' and 'C-r'. ++++ +*** New command 'xwidget-webkit-browse-history'. +This command displays a buffer containing the page load history of +the current WebKit widget, and allows you to navigate it. + --- *** On X11, the WebKit inspector is now available inside xwidgets. To access the inspector, right click on the widget and select "Inspect @@ -497,6 +598,14 @@ The newly created buffer will be displayed via 'display-buffer', which can be customized through the usual mechanism of 'display-buffer-alist' and friends. +** Tramp + +--- +*** Tramp supports abbreviating remote home directories now. +When calling 'abbreviate-file-name' on a Tramp filename, the result +will abbreviate the user's home directory, for example by abbreviating +"/ssh:user@host:/home/user" to "/ssh:user@host:~". + * New Modes and Packages in Emacs 29.1 @@ -585,6 +694,85 @@ Use 'exif-parse-file' and 'exif-field' instead. * Lisp Changes in Emacs 29.1 ++++ +** New function 'get-display-property'. +This is like 'get-text-property', but works on the 'display' text +property. + ++++ +** New function 'add-text-display-property'. +This is like 'put-text-property', but works on the 'display' text +property. + ++++ +** New 'min-width' 'display' property. +This allows setting a minimum display width for a region of text. + +** Keymaps and key definitions + ++++ +*** New functions for defining and manipulating keystrokes have been added. +These all take just the syntax defined by 'key-valid-p'. None of the +older functions have been depreciated or altered, but are deemphasised +in the documentation. + ++++ +*** Use 'keymap-set' instead of 'define-key'. + ++++ +*** Use 'keymap-global-set' instead of 'global-set-key'. + ++++ +*** Use 'keymap-local-set' instead of 'local-set-key'. + ++++ +*** Use 'keymap-global-unset' instead of 'global-unset-key'. + ++++ +*** Use 'keymap-local-unset' instead of 'local-unset-key'. + ++++ +*** Use 'keymap-substitute' instead of 'substitute-key-definition'. + ++++ +*** Use 'keymap-set-after' instead of 'define-key-after'. + ++++ +*** Use 'keymap-lookup' instead of 'lookup-keymap' and 'key-binding'. + ++++ +*** Use 'keymap-local-lookup' instead of 'local-key-binding'. + ++++ +*** Use 'keymap-global-lookup' instead of 'global-key-binding'. + ++++ +*** 'define-key' now takes an optional REMOVE argument. +If non-nil, remove the definition from the keymap. This is subtly +different from setting a definition to nil (when the keymap has a +parent). + ++++ +*** New function 'key-valid-p'. +The 'kbd' function is quite permissive, and will try to return +something usable even if the syntax of the argument isn't completely +correct. The 'key-valid-p' predicate does a stricter check of the +syntax. + +--- +*** New function 'key-parse'. +This is like 'kbd', but only returns vectors instead of a mix of +vectors and strings. + ++++ +** New substitution in docstrings and 'substitute-command-keys'. +Use \\`KEYSEQ' to insert a literal key sequence "KEYSEQ" (for example +\\`C-k') in a docstring or when calling 'substitute-command-keys', +which will use the same face as a command substitution. This should +be used only when a key sequence has no corresponding command, for +example when it is read directly with 'read-key-sequence'. It must be +a valid key sequence according to 'key-valid-p'. + +++ ** New function 'file-name-split'. This returns a list of all the components of a file name. @@ -632,6 +820,9 @@ This convenience function is useful when writing code that parses files at run-time, and allows Lisp programs to re-parse files only when they have changed. ++++ +** 'abbreviate-file-name' now respects magic file name handlers. + --- ** New function 'font-has-char-p'. This can be used to check whether a specific font has a glyph for a @@ -674,13 +865,6 @@ The 'tabulated-list-entries' variable now supports using an image descriptor, which means to insert an image in that column instead of text. See the documentation string of that variable for details. -+++ -** 'define-key' now understands a new strict 'kbd' representation for keys. -The '(define-key map ["C-c M-f"] #'some-command)' syntax is now -supported, and is like the 'kbd' representation, but is stricter. If -the string doesn't represent a valid key sequence, an error is -signalled (both when evaluating and byte compiling). - +++ ** :keys in 'menu-item' can now be a function. If so, it is called whenever the menu is computed, and can be used to @@ -717,13 +901,6 @@ This macro allows defining keymap variables more conveniently. ** 'kbd' can now be used in built-in, preloaded libraries. It no longer depends on edmacro.el and cl-lib.el. -+++ -** New function 'kbd-valid-p'. -The 'kbd' function is quite permissive, and will try to return -something usable even if the syntax of the argument isn't completely -correct. The 'kbd-valid-p' predicate does a stricter check of the -syntax. - +++ ** New function 'image-at-point-p'. This function returns t if point is on a valid image, and nil @@ -781,6 +958,21 @@ markup, and passing the URI of the file as an argument to Some new functions, such as 'xwidget-webkit-search', have been added for performing searches on WebKit xwidgets. ++++ +*** New function 'xwidget-webkit-back-forward-list'. +This function is used to obtain the history of page-loads in a given +WebKit xwidget. + ++++ +*** New function 'xwidget-webkit-estimated-load-progress'. +This function is used to obtain the estimated progress of page loading +in a given WebKit xwidget. + ++++ +*** New function 'xwidget-webkit-stop-loading'. +This function is used to terminate all data transfer during page loads +in a given WebKit xwidget. + +++ *** 'load-changed' xwidget events are now more detailed. In particular, they can now have different arguments based on the @@ -792,8 +984,13 @@ commits to the load. +++ *** New event type 'xwidget-display-event'. These events are sent whenever an xwidget requests that Emacs display -another xwidget. The only argument to this event is the xwidget that -should be displayed. +another xwidget. The only arguments to this event are the xwidget +that should be displayed, and the xwidget that asked to display it. + ++++ +*** New function 'xwidget-webkit-set-cookie-storage-file'. +This function is used to control where and if an xwidget stores +cookies set by web pages on disk. * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/etc/PROBLEMS b/etc/PROBLEMS index f506881a4ba..acff3be7da4 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -1022,6 +1022,15 @@ modern fonts are used, such as Noto Emoji or Ebrima. The solution is to switch to a configuration that uses HarfBuzz as its shaping engine, where these problems don't exist. +** On Haiku, some proportionally-spaced fonts display with artifacting. + +This is a Haiku bug: https://dev.haiku-os.org/ticket/17229, which can +be remedied by using a different font that does not exhibit this +problem, or by configuring Emacs '--with-be-cairo'. + +So far, Bitstream Charter and Noto Sans have been known to exhibit +this problem, while Noto Sans Display is known to not do so. + * Internationalization problems ** M-{ does not work on a Spanish PC keyboard. @@ -1105,6 +1114,13 @@ In your ~/.Xresources file, then run And restart Emacs. +** On Haiku, BeCJK doesn't work properly with Emacs + +Some popular Haiku input methods such BeCJK are known to behave badly +when interacting with Emacs, in ways such as stealing input focus and +displaying popup windows that don't disappear. If you are affected, +you should use an Emacs input method instead. + * X runtime problems ** X keyboard problems diff --git a/etc/compilation.txt b/etc/compilation.txt index 01d4df1b09d..34d8c53c9a6 100644 --- a/etc/compilation.txt +++ b/etc/compilation.txt @@ -310,6 +310,9 @@ G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found. file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found. {standard input}:27041: Warning: end of file not at end of a line; newline inserted boost/container/detail/flat_tree.hpp:589:25: [ skipping 5 instantiation contexts, use -ftemplate-backtrace-limit=0 to disable ] + | + |board.h:60:21: + | 60 | #define I(b, C) ((C).y * (b)->width + (C).x) * Guile backtrace, 2.0.11 diff --git a/etc/refcards/orgcard.tex b/etc/refcards/orgcard.tex index d3715948d65..181516172d2 100644 --- a/etc/refcards/orgcard.tex +++ b/etc/refcards/orgcard.tex @@ -1,5 +1,5 @@ % Reference Card for Org Mode -\def\orgversionnumber{9.5} +\def\orgversionnumber{9.5.1} \def\versionyear{2021} % latest update \input emacsver.tex diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index 350524779d6..5a73e655f30 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -4,8 +4,8 @@ ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Package-Requires: ((emacs "26.1")) +;; Version: 1.7.0 +;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 7ab985c0771..f7d38ac2dea 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -4,8 +4,8 @@ ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Last-Modified: <2021-09-29 08:47:03 +0300> +;; Version: 1.7.0 +;; Last-Modified: <2021-11-18 12:28:22 +0200> ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -31,7 +31,7 @@ ;; This file contains all customization variables, helper functions, ;; interactive commands, and face specifications. Please refer to the ;; official Info manual for further documentation (distributed with the -;; themes, or available at: ). +;; themes, or available at: ). ;; ;; The themes share the following customization variables: ;; @@ -39,8 +39,9 @@ ;; modus-themes-org-agenda (alist) ;; modus-themes-bold-constructs (boolean) ;; modus-themes-inhibit-reload (boolean) +;; modus-themes-intense-markup (boolean) ;; modus-themes-italic-constructs (boolean) -;; modus-themes-no-mixed-fonts (boolean) +;; modus-themes-mixed-fonts (boolean) ;; modus-themes-scale-headings (boolean) ;; modus-themes-subtle-line-numbers (boolean) ;; modus-themes-success-deuteranopia (boolean) @@ -59,6 +60,7 @@ ;; modus-themes-prompts (choice) ;; modus-themes-region (choice) ;; modus-themes-syntax (choice) +;; modus-themes-mode-line-padding (natnum) ;; ;; The default scale for headings is as follows (it can be customized as ;; well---remember, no scaling takes place by default): @@ -238,6 +240,7 @@ ;; ido-mode ;; iedit ;; iflipb +;; image-dired ;; imenu-list ;; indium ;; info @@ -278,6 +281,7 @@ ;; mu4e ;; mu4e-conversation ;; multiple-cursors +;; nano-modeline ;; neotree ;; no-emoji ;; notmuch @@ -378,6 +382,7 @@ ;; vc-annotate (C-x v g) ;; vdiff ;; vertico +;; vertico-quick ;; vimish-fold ;; visible-mark ;; visual-regexp @@ -1475,7 +1480,7 @@ The actual styling of the face is done by `modus-themes-faces'." (defface modus-themes-variable-pitch nil "Generic face for applying a conditional `variable-pitch'. -This behaves in accordance with `modus-themes-no-mixed-fonts', +This behaves in accordance with `modus-themes-mixed-fonts', `modus-themes-variable-pitch-headings' for all heading levels, and `modus-themes-variable-pitch-ui'. @@ -1484,7 +1489,7 @@ The actual styling of the face is done by `modus-themes-faces'." (defface modus-themes-fixed-pitch nil "Generic face for applying a conditional `fixed-pitch'. -This behaves in accordance with `modus-themes-no-mixed-fonts'. +This behaves in accordance with `modus-themes-mixed-fonts'. The actual styling of the face is done by `modus-themes-faces'." :group 'modus-theme-faces) @@ -1782,30 +1787,43 @@ This includes the mode line, header line, tab bar, and tab line." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) UI typeface")) -(defcustom modus-themes-no-mixed-fonts nil - "Disable inheritance from `fixed-pitch' in some faces. +(define-obsolete-variable-alias + 'modus-themes-no-mixed-fonts + 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0") -This is done by default to allow spacing-sensitive constructs, -such as Org tables and code blocks, to remain monospaced when -users opt for something like the command `variable-pitch-mode'. -The downside with the default is that users need to explicitly -configure the font family of `fixed-pitch' in order to get a -consistent experience. That may be something they do not want to -do. Hence this option to disable any kind of technique for -mixing fonts." +(defcustom modus-themes-mixed-fonts nil + "Non-nil to enable inheritance from `fixed-pitch' in some faces. + +This is done to allow spacing-sensitive constructs, such as Org +tables and code blocks, to remain monospaced when users opt for +something like the command `variable-pitch-mode'. + +Users may need to explicitly configure the font family of +`fixed-pitch' in order to get a consistent experience." :group 'modus-themes - :package-version '(modus-themes . "1.0.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type 'boolean :set #'modus-themes--set-option :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) No mixed fonts")) + :link '(info-link "(modus-themes) Mixed fonts")) (defconst modus-themes--headings-choice '(set :tag "Properties" :greedy t (const :tag "Background color" background) (const :tag "Overline" overline) - (const :tag "No bold weight" no-bold) + (choice :tag "Font weight (must be supported by the typeface)" + (const :tag "Bold (default)" nil) + (const :tag "Thin" thin) + (const :tag "Ultra-light" ultralight) + (const :tag "Extra-light" extralight) + (const :tag "Light" light) + (const :tag "Semi-light" semilight) + (const :tag "Regular" regular) + (const :tag "Medium" medium) + (const :tag "Semi-bold" semibold) + (const :tag "Extra-bold" extrabold) + (const :tag "Ultra-bold" ultrabold)) (choice :tag "Colors" (const :tag "Subtle colors" nil) (const :tag "Rainbow colors" rainbow) @@ -1839,21 +1857,27 @@ heading. A `background' property adds a subtle tinted color to the background of the heading. -A `no-bold' property removes the bold weight from the heading's -text. - A `monochrome' property makes all headings the same base color, which is that of the default for the active theme (black/white). When `background' is also set, `monochrome' changes its color to gray. If both `monochrome' and `rainbow' are set, the former takes precedence. +The symbol of a weight attribute adjusts the font of the heading +accordingly, such as `light', `semibold', etc. Valid symbols are +defined in the internal variable `modus-themes--heading-weights'. +The absence of a weight means that bold will be used by virtue of +inheriting the `bold' face (check the manual for tweaking bold +and italic faces). For backward compatibility, the `no-bold' +value is accepted, though users are encouraged to specify a +`regular' weight instead. + Combinations of any of those properties are expressed as a list, like in these examples: - (no-bold) + (semibold) (rainbow background) - (overline monochrome no-bold) + (overline monochrome semibold) The order in which the properties are set is not significant. @@ -1862,7 +1886,7 @@ In user configuration files the form may look like this: (setq modus-themes-headings '((1 . (background overline rainbow)) (2 . (background overline)) - (t . (overline no-bold)))) + (t . (overline semibold)))) When defining the styles per heading level, it is possible to pass a non-nil value (t) instead of a list of properties. This @@ -1875,7 +1899,7 @@ will retain the original aesthetic for that level. For example: (setq modus-themes-headings '((1 . (background overline)) - (2 . (rainbow no-bold)) + (2 . (rainbow semibold)) (t . t))) ; default style for all other levels For Org users, the extent of the heading depends on the variable @@ -1887,8 +1911,8 @@ Also read `modus-themes-scale-headings' to change the height of headings and `modus-themes-variable-pitch-headings' to make them use a proportionately spaced font." :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type `(alist :options ,(mapcar (lambda (el) (list el modus-themes--headings-choice)) @@ -1909,7 +1933,7 @@ combinations: (setq modus-themes-org-agenda '((header-block . (variable-pitch scale-title)) (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + (event . (accented italic varied)) (scheduled . uniform) (habit . traffic-light))) @@ -1963,26 +1987,42 @@ For example: (header-date . (grayscale workaholic bold-today)) (header-date . (grayscale workaholic bold-today scale-heading)) -An `event' key covers events from the diary and other entries -that derive from a symbolic expression or sexp (e.g. phases of -the moon, holidays). By default those have a gray -foreground (the default is a nil value or an empty list). This -key accepts a list of properties. Those are: +An `event' key covers (i) headings with a plain time stamp that +are shown on the agenda, also known as events, (ii) entries +imported from the diary, and (iii) other items that derive from a +symbolic expression or sexp (phases of the moon, holidays, etc.). +By default all those look the same and have a subtle foreground +color (the default is a nil value or an empty list). This key +accepts a list of properties. Those are: - `scale-small' reduces the height of the entries to the value of the user option `modus-themes-scale-small' (0.9 the height of - the main font size by default). + the main font size by default). This work best when the + relevant entries have no tags associated with them and when the + user is interested in reducing their presence in the agenda + view. - `accented' applies an accent value to the event's foreground, - replacing the original gray. + replacing the original gray. It makes all entries stand out more. - `italic' adds a slant to the font's forms (italic or oblique - forms, depending on the typeface) + forms, depending on the typeface). +- `varied' differentiates between events with a plain time stamp + and entries that are generated from either the diary or a + symbolic expression. It generally puts more emphasis on + events. When `varied' is combined with `accented', it makes + only events use an accent color, while diary/sexp entries + retain their original subtle foreground. When `varied' is used + in tandem with `italic', it applies a slant only to diary and + sexp entries, not events. And when `varied' is the sole + property passed to the `event' key, it has the same meaning as + the list (italic varied). The combination of `varied', + `accented', `italic' covers all of the aforementioned cases. For example: (event . nil) - (event . (scale-small)) - (event . (scale-small accented)) - (event . (scale-small accented italic)) + (event . (italic)) + (event . (accented italic)) + (event . (accented italic varied)) A `scheduled' key applies to tasks with a scheduled date. By default (a nil value), these use varying shades of yellow to @@ -2038,8 +2078,8 @@ For example: (habit . simplified) (habit . traffic-light)" :group 'modus-themes - :package-version '(modus-themes . "1.6.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type '(set (cons :tag "Block header" (const header-block) @@ -2065,7 +2105,8 @@ For example: (set :tag "Text presentation" :greedy t (const :tag "Use smaller font size (`modus-themes-scale-small')" scale-small) (const :tag "Apply an accent color" accented) - (const :tag "Italic font slant (oblique forms)" italic))) + (const :tag "Italic font slant (oblique forms)" italic) + (const :tag "Differentiate events from diary/sexp entries" varied))) (cons :tag "Scheduled tasks" (const scheduled) (choice (const :tag "Yellow colors to distinguish current and future tasks (default)" nil) @@ -2289,12 +2330,12 @@ to the affected text. The property `background' adds a color-coded background. The property `intense' amplifies the applicable colors if -`background' and/or `text-only' are set. If `intense' is set on -its own, then it implies `text-only'. +`background' and/or `text-also' are set. If `intense' is set on +its own, then it implies `text-also'. -To disable fringe indicators for Flymake or Flycheck, refer to -variables `flymake-fringe-indicator-position' and -`flycheck-indication-mode', respectively. +The property `faint' uses nuanced colors for the underline and +for the foreground when `text-also' is included. If both `faint' +and `intense' are specified, the former takes precedence. Combinations of any of those properties can be expressed in a list, as in those examples: @@ -2312,15 +2353,21 @@ In user configuration files the form may look like this: NOTE: The placement of the straight underline, though not the wave style, is controlled by the built-in variables `underline-minimum-offset', `x-underline-at-descent-line', -`x-use-underline-position-properties'." +`x-use-underline-position-properties'. + +To disable fringe indicators for Flymake or Flycheck, refer to +variables `flymake-fringe-indicator-position' and +`flycheck-indication-mode', respectively." :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type '(set :tag "Properties" :greedy t (const :tag "Straight underline" straight-underline) (const :tag "Colorise text as well" text-also) - (const :tag "Increase color intensity" intense) - (const :tag "With background" background)) + (const :tag "With background" background) + (choice :tag "Overall coloration" + (const :tag "Intense colors" intense) + (const :tag "Faint colors" faint))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Language checkers")) @@ -2502,6 +2549,17 @@ instead of a box style, it is advised to set :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mode line")) +(defcustom modus-themes-mode-line-padding 6 + "Padding for `modus-themes-mode-line'. +The value is expressed as a positive integer." + :group 'modus-themes + :package-version '(modus-themes . "1.7.0") + :version "29.1" + :type 'natnum + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Mode line")) + (defcustom modus-themes-diffs nil "Adjust the overall style of diffs. @@ -2643,16 +2701,6 @@ In user configuration files the form may look like this: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Command prompts")) -(defcustom modus-themes-intense-hl-line nil - "Use a more prominent background for command `hl-line-mode'." - :group 'modus-themes - :package-version '(modus-themes . "1.0.0") - :version "28.1" - :type 'boolean - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Line highlighting")) - (make-obsolete 'modus-themes-intense-hl-line 'modus-themes-hl-line "1.3.0") (defcustom modus-themes-hl-line nil @@ -2708,6 +2756,22 @@ results with underlines." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Line numbers")) +(defcustom modus-themes-intense-markup nil + "Use more intense markup in Org, Markdown, and related. +The default style for certain markup types like inline code and +verbatim constructs in Org and related major modes is a subtle +foreground color combined with a subtle background. + +With a non-nil value (t), these constructs will use a more +prominent background and foreground color combination instead." + :group 'modus-themes + :package-version '(modus-themes . "1.7.0") + :version "29.1" + :type 'boolean + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Intense markup")) + (defcustom modus-themes-paren-match nil "Control the style of matching parentheses or delimiters. @@ -2913,12 +2977,14 @@ In user configuration files the form may look like this: This is to account for red-green color deficiency. -The present customization option should apply to all contexts where -there can be a color-coded distinction between success and failure, -to-do and done, and so on. +The present customization option applies to all contexts where +there can be a color-coded distinction between success or +failure, to-do or done, mark for selection or deletion (e.g. in +Dired), current and lazily highlighted search matches, and so on. -Diffs, which have a red/green dichotomy by default, can also be -configured to conform with deuteranopia: `modus-themes-diffs'." +Diffs, which rely on a red/green dichotomy by default, can also +be configured to meet the needs of users with deuteranopia via +the option `modus-themes-diffs'." :group 'modus-themes :package-version '(modus-themes . "1.4.0") :version "28.1" @@ -3024,7 +3090,7 @@ Those are stored in `modus-themes-faces' and (defun modus-themes--fixed-pitch () "Conditional application of `fixed-pitch' inheritance." - (unless modus-themes-no-mixed-fonts + (when modus-themes-mixed-fonts (list :inherit 'fixed-pitch))) (defun modus-themes--variable-pitch () @@ -3054,14 +3120,23 @@ combines with the theme's primary background (white/black)." (list :background (or altbg 'unspecified) :foreground altfg) (list :background mainbg :foreground mainfg))) -(defun modus-themes--lang-check (underline subtlefg intensefg intensefg-alt subtlebg intensebg) +(defun modus-themes--markup (mainfg intensefg &optional mainbg intensebg) + "Conditional use of colors for markup in Org and others. +MAINBG is the default background. MAINFG is the default +foreground. INTENSEBG and INTENSEFG must be more colorful +variants." + (if modus-themes-intense-markup + (list :background (or intensebg 'unspecified) :foreground intensefg) + (list :background (or mainbg 'unspecified) :foreground mainfg))) + +(defun modus-themes--lang-check (underline subtlefg intensefg intensefg-alt subtlebg intensebg faintfg) "Conditional use of foreground colors for language checkers. UNDERLINE is a color-code value for the affected text's underline property. SUBTLEFG and INTENSEFG follow the same color-coding pattern and represent a value that is faint or vibrant respectively. INTENSEFG-ALT is used when the intensity is high. SUBTLEBG and INTENSEBG are color-coded background colors that -differ in overall intensity." +differ in overall intensity. FAINTFG is a nuanced color." (let ((modus-themes-lang-checkers (if (listp modus-themes-lang-checkers) modus-themes-lang-checkers @@ -3074,12 +3149,16 @@ differ in overall intensity." ('straight-underline '(straight-underline)))))) (list :underline (list :color - underline + (if (memq 'faint modus-themes-lang-checkers) + faintfg underline) :style (if (memq 'straight-underline modus-themes-lang-checkers) 'line 'wave)) :background (cond + ((and (memq 'background modus-themes-lang-checkers) + (memq 'faint modus-themes-lang-checkers)) + subtlebg) ((and (memq 'background modus-themes-lang-checkers) (memq 'intense modus-themes-lang-checkers)) intensebg) @@ -3087,6 +3166,9 @@ differ in overall intensity." subtlebg)) :foreground (cond + ((and (memq 'faint modus-themes-lang-checkers) + (memq 'text-also modus-themes-lang-checkers)) + faintfg) ((and (memq 'background modus-themes-lang-checkers) (memq 'intense modus-themes-lang-checkers)) intensefg-alt) @@ -3312,6 +3394,18 @@ an alternative to the default value." "Get cdr of KEY in ALIST." (cdr (assoc key alist))) +(defvar modus-themes--heading-weights + '( thin ultralight extralight light semilight regular medium + semibold bold heavy extrabold ultrabold) + "List of font weights used by `modus-themes--heading'.") + +(defun modus-themes--heading-weight (list) + "Search for `modus-themes--heading' weight in LIST." + (catch 'found + (dolist (elt list) + (when (memq elt modus-themes--heading-weights) + (throw 'found elt))))) + (defun modus-themes--heading (level fg fg-alt bg bg-gray border) "Conditional styles for `modus-themes-headings'. @@ -3323,8 +3417,9 @@ values. BG-GRAY is a gray background. BORDER is a color value that combines well with the background and foreground." (let* ((key (modus-themes--key-cdr level modus-themes-headings)) (style (or key (modus-themes--key-cdr t modus-themes-headings))) + (style-listp (listp style)) (modus-themes-headings - (if (listp style) + (if style-listp style ;; translation layer for legacy values (pcase style @@ -3345,15 +3440,16 @@ that combines well with the background and foreground." ('rainbow-section-no-bold '(no-bold rainbow background overline)) ('section '(background overline)) ('section-no-bold '(background overline no-bold))))) - (var (if modus-themes-variable-pitch-headings - 'variable-pitch - 'unspecified)) + (var (when modus-themes-variable-pitch-headings 'variable-pitch)) (varbold (if var (append (list 'bold) (list var)) - 'bold))) + 'bold)) + (weight (when style-listp (modus-themes--heading-weight style)))) (list :inherit (cond - ((memq 'no-bold modus-themes-headings) + ;; `no-bold' is for backward compatibility because we cannot + ;; deprecate a variable's value. + ((or weight (memq 'no-bold modus-themes-headings)) var) (varbold)) :background @@ -3371,6 +3467,8 @@ that combines well with the background and foreground." ((memq 'rainbow modus-themes-headings) fg-alt) (fg)) + :weight + (or weight 'unspecified) :overline (if (memq 'overline modus-themes-headings) border @@ -3430,24 +3528,42 @@ weight. Optional UL applies an underline." t 'unspecified)))) -(defun modus-themes--agenda-event (fg) +(defun modus-themes--agenda-event (fg-accent &optional varied) "Control the style of the Org agenda events. -FG is the accent color to use." +FG-ACCENT is the accent color to use. Optional VARIED is a +toggle to behave in accordance with the semantics of the `varied' +property that the `event' key accepts in +`modus-themes-org-agenda'." (let ((properties (modus-themes--key-cdr 'event modus-themes-org-agenda))) (list :height (if (memq 'scale-small properties) modus-themes-scale-small 'unspecified) :foreground - (if (memq 'accented properties) - fg + (cond + ((or (and (memq 'varied properties) varied) + (and (memq 'accented properties) + (memq 'varied properties) + varied)) 'unspecified) + ((memq 'accented properties) + fg-accent) + ('unspecified)) :inherit (cond + ((and (memq 'italic properties) + (memq 'varied properties) + varied) + '(shadow italic)) ((and (memq 'accented properties) - (memq 'italic properties)) - 'italic) - ((memq 'italic properties) + (memq 'varied properties) + varied) + 'shadow) + ((or (and (memq 'varied properties) varied) + (and (memq 'italic properties) varied)) + '(shadow italic)) + ((and (memq 'italic properties) + (not (memq 'varied properties))) '(shadow italic)) ('shadow))))) @@ -3512,6 +3628,13 @@ set to `rainbow'." ('rainbow (list :background bgaccent :foreground fgaccent)) (_ (list :background bg :foreground fg)))) +(defun modus-themes--mode-line-padding () + "Determine mode line padding value. +See `modus-themes--mode-line-attrs'." + (if (natnump modus-themes-mode-line-padding) + modus-themes-mode-line-padding + 6)) ; the default value + (defun modus-themes--mode-line-attrs (fg bg fg-alt bg-alt fg-accent bg-accent border border-3d &optional alt-style fg-distant) "Color combinations for `modus-themes-mode-line'. @@ -3528,7 +3651,8 @@ line's box property. Optional FG-DISTANT should be close to the main background values. It is intended to be used as a distant-foreground property." - (let ((modus-themes-mode-line + (let ((padding (modus-themes--mode-line-padding)) + (modus-themes-mode-line (if (listp modus-themes-mode-line) modus-themes-mode-line ;; translation layer for legacy values @@ -3552,10 +3676,10 @@ property." (cons fg-alt bg-alt)) ((cons fg bg)))) (box (cond ((memq 'moody modus-themes-mode-line) - nil) + 'unspecified) ((and (memq '3d modus-themes-mode-line) (memq 'padded modus-themes-mode-line)) - (list :line-width 4 + (list :line-width padding :color (cond ((and (memq 'accented modus-themes-mode-line) (memq 'borderless modus-themes-mode-line)) @@ -3567,9 +3691,9 @@ property." :style (when alt-style 'released-button))) ((and (memq 'accented modus-themes-mode-line) (memq 'padded modus-themes-mode-line)) - (list :line-width 6 :color bg-accent)) + (list :line-width padding :color bg-accent)) ((memq 'padded modus-themes-mode-line) - (list :line-width 6 :color bg)) + (list :line-width padding :color bg)) ((memq '3d modus-themes-mode-line) (list :line-width 1 :color @@ -3579,14 +3703,17 @@ property." ((memq 'borderless modus-themes-mode-line) bg) (border-3d)) :style (when alt-style 'released-button))) + ((and (memq 'accented modus-themes-mode-line) + (memq 'borderless modus-themes-mode-line)) + bg-accent) ((memq 'borderless modus-themes-mode-line) bg) ((memq 'padded modus-themes-mode-line) - (list :line-width 6 :color bg)) + (list :line-width padding :color bg)) (border))) (line (cond ((not (or (memq 'moody modus-themes-mode-line) (memq 'padded modus-themes-mode-line))) - nil) + 'unspecified) ((and (memq 'borderless modus-themes-mode-line) (memq 'accented modus-themes-mode-line)) bg-accent) @@ -4007,6 +4134,7 @@ as when they are declared in the `:config' phase)." (defun modus-themes-load-operandi () "Load `modus-operandi' and disable `modus-vivendi'. Also run `modus-themes-after-load-theme-hook'." + (interactive) (disable-theme 'modus-vivendi) (load-theme 'modus-operandi t) (run-hooks 'modus-themes-after-load-theme-hook)) @@ -4015,6 +4143,7 @@ Also run `modus-themes-after-load-theme-hook'." (defun modus-themes-load-vivendi () "Load `modus-vivendi' and disable `modus-operandi'. Also run `modus-themes-after-load-theme-hook'." + (interactive) (disable-theme 'modus-operandi) (load-theme 'modus-vivendi t) (run-hooks 'modus-themes-after-load-theme-hook)) @@ -4169,7 +4298,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(modus-themes-pseudo-header ((,class :inherit bold :foreground ,fg-main))) `(modus-themes-mark-alt ((,class :inherit bold :background ,bg-mark-alt :foreground ,fg-mark-alt))) `(modus-themes-mark-del ((,class :inherit bold :background ,bg-mark-del :foreground ,fg-mark-del))) - `(modus-themes-mark-sel ((,class :inherit bold :background ,bg-mark-sel :foreground ,fg-mark-sel))) + `(modus-themes-mark-sel ((,class :inherit bold + :background ,@(modus-themes--success-deuteran + cyan-refine-bg + bg-mark-sel) + :foreground ,fg-mark-sel))) `(modus-themes-mark-symbol ((,class :inherit bold :foreground ,blue-alt))) ;;;;; heading levels ;; styles for regular headings used in Org, Markdown, Info, etc. @@ -4225,13 +4358,13 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; language checkers `(modus-themes-lang-error ((,class ,@(modus-themes--lang-check fg-lang-underline-error fg-lang-error - red red-refine-fg red-nuanced-bg red-refine-bg)))) + red red-refine-fg red-nuanced-bg red-refine-bg red-faint)))) `(modus-themes-lang-note ((,class ,@(modus-themes--lang-check fg-lang-underline-note fg-lang-note - blue-alt blue-refine-fg blue-nuanced-bg blue-refine-bg)))) + blue-alt blue-refine-fg blue-nuanced-bg blue-refine-bg blue-faint)))) `(modus-themes-lang-warning ((,class ,@(modus-themes--lang-check fg-lang-underline-warning fg-lang-warning - yellow yellow-refine-fg yellow-nuanced-bg yellow-refine-bg)))) + yellow yellow-refine-fg yellow-nuanced-bg yellow-refine-bg yellow-faint)))) ;;;;; other custom faces `(modus-themes-bold ((,class ,@(modus-themes--bold-weight)))) `(modus-themes-hl-line ((,class ,@(modus-themes--hl-line @@ -4276,15 +4409,16 @@ by virtue of calling either of `modus-themes-load-operandi' and `(buffer-menu-buffer ((,class :inherit bold))) `(comint-highlight-input ((,class :inherit bold))) `(comint-highlight-prompt ((,class :inherit modus-themes-prompt))) + `(confusingly-reordered ((,class :inherit modus-themes-lang-error))) `(error ((,class :inherit bold :foreground ,red))) `(escape-glyph ((,class :foreground ,fg-escape-char-construct))) - `(file-name-shadow ((,class :foreground ,fg-unfocused))) + `(file-name-shadow ((,class :inherit (shadow italic)))) `(header-line ((,class ,@(modus-themes--variable-pitch-ui) :background ,bg-header :foreground ,fg-header))) `(header-line-highlight ((,class :inherit modus-themes-active-blue))) `(help-argument-name ((,class :inherit modus-themes-slant :foreground ,cyan))) - `(help-key-binding ((,class :box (:line-width (1 . -1) :color ,bg-region) ; NOTE: box syntax is for Emacs28 - :background ,bg-inactive))) + `(help-key-binding ((,class :box (:line-width (-1 . -1) :color ,bg-active) ; NOTE: box syntax is for Emacs28 + :background ,bg-alt))) `(homoglyph ((,class :foreground ,red-alt-faint))) `(ibuffer-locked-buffer ((,class :foreground ,yellow-alt-other-faint))) `(italic ((,class :slant italic))) @@ -4316,7 +4450,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(widget-button-pressed ((,class :inherit widget-button :foreground ,magenta))) `(widget-documentation ((,class :foreground ,green))) `(widget-field ((,class :background ,bg-alt :foreground ,fg-dim))) - `(widget-inactive ((,class :foreground ,fg-alt))) + `(widget-inactive ((,class :inherit shadow :background ,bg-dim))) `(widget-single-line-field ((,class :inherit widget-field))) ;;;;; ag `(ag-hit-face ((,class :foreground ,fg-special-cold))) @@ -4505,7 +4639,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(bongo-marked-track ((,class :foreground ,fg-mark-alt))) `(bongo-marked-track-line ((,class :background ,bg-mark-alt))) `(bongo-played-track ((,class :foreground ,fg-unfocused :strike-through t))) - `(bongo-track-length ((,class :foreground ,fg-alt))) + `(bongo-track-length ((,class :inherit shadow))) `(bongo-track-title ((,class :foreground ,blue-active))) `(bongo-unfilled-seek-bar ((,class :background ,bg-special-cold :foreground ,fg-main))) ;;;;; boon @@ -4569,7 +4703,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; cfrs `(cfrs-border-color ((,class :background ,fg-window-divider-inner))) ;;;;; change-log and log-view (`vc-print-log' and `vc-print-root-log') - `(change-log-acknowledgment ((,class :foreground ,fg-alt))) + `(change-log-acknowledgment ((,class :inherit shadow))) `(change-log-conditionals ((,class :foreground ,yellow))) `(change-log-date ((,class :foreground ,cyan))) `(change-log-email ((,class :foreground ,cyan-alt-other))) @@ -4609,7 +4743,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(cider-stacktrace-filter-active-face ((,class :foreground ,cyan-alt :underline t))) `(cider-stacktrace-filter-inactive-face ((,class :foreground ,cyan-alt))) `(cider-stacktrace-fn-face ((,class :inherit bold :foreground ,fg-main))) - `(cider-stacktrace-ns-face ((,class :inherit italic :foreground ,fg-alt))) + `(cider-stacktrace-ns-face ((,class :inherit (shadow italic)))) `(cider-stacktrace-promoted-button-face ((,class :box (:line-width 3 :color ,fg-alt :style released-button) :foreground ,red))) `(cider-stacktrace-suppressed-button-face ((,class :box (:line-width 3 :color ,fg-alt :style pressed-button) :background ,bg-alt :foreground ,fg-alt))) @@ -4658,6 +4792,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(company-tooltip-annotation-selection ((,class :inherit bold :foreground ,fg-main))) `(company-tooltip-common ((,class :inherit bold :foreground ,blue-alt))) `(company-tooltip-common-selection ((,class :foreground ,fg-main))) + `(company-tooltip-deprecated ((,class :inherit company-tooltip :strike-through t))) `(company-tooltip-mouse ((,class :inherit modus-themes-intense-blue))) `(company-tooltip-search ((,class :inherit (modus-themes-search-success-lazy bold)))) `(company-tooltip-search-selection ((,class :inherit (modus-themes-search-success bold) :underline t))) @@ -4698,10 +4833,10 @@ by virtue of calling either of `modus-themes-load-operandi' and `(consult-preview-error ((,class :inherit modus-themes-intense-red))) `(consult-preview-line ((,class :background ,bg-hl-alt-intense))) ;;;;; corfu - `(corfu-background ((,class :background ,bg-alt))) `(corfu-current ((,class :inherit bold :background ,cyan-subtle-bg))) `(corfu-bar ((,class :background ,fg-alt))) `(corfu-border ((,class :background ,bg-active))) + `(corfu-default ((,class :background ,bg-alt))) ;;;;; counsel `(counsel-active-mode ((,class :foreground ,magenta-alt-other))) `(counsel-application-name ((,class :foreground ,red-alt-other))) @@ -4758,7 +4893,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(custom-comment ((,class :inherit shadow))) `(custom-comment-tag ((,class :background ,bg-alt :foreground ,yellow-alt-other))) `(custom-face-tag ((,class :inherit bold :foreground ,blue-intense))) - `(custom-group-tag ((,class :inherit bold :foreground ,green-intense))) + `(custom-group-tag ((,class :inherit modus-themes-pseudo-header :foreground ,magenta-alt))) `(custom-group-tag-1 ((,class :inherit modus-themes-special-warm))) `(custom-invalid ((,class :inherit (modus-themes-intense-red bold)))) `(custom-modified ((,class :inherit modus-themes-subtle-cyan))) @@ -4814,7 +4949,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(deft-filter-string-face ((,class :foreground ,green-intense))) `(deft-header-face ((,class :inherit bold :foreground ,fg-special-warm))) `(deft-separator-face ((,class :inherit shadow))) - `(deft-summary-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) + `(deft-summary-face ((,class :inherit (shadow modus-themes-slant)))) `(deft-time-face ((,class :foreground ,fg-special-cold))) `(deft-title-face ((,class :inherit bold :foreground ,fg-main))) ;;;;; dictionary @@ -4862,7 +4997,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dir-treeview-audio-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,magenta-alt))) `(dir-treeview-control-face ((,class :inherit shadow))) `(dir-treeview-control-mouse-face ((,class :inherit highlight))) - `(dir-treeview-default-icon-face ((,class :inherit bold :family "Font Awesome" :foreground ,fg-alt))) + `(dir-treeview-default-icon-face ((,class :inherit (shadow bold) :family "Font Awesome"))) `(dir-treeview-default-filename-face ((,class :foreground ,fg-main))) `(dir-treeview-directory-face ((,class :foreground ,blue))) `(dir-treeview-directory-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,blue-alt))) @@ -5484,8 +5619,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(git-gutter-fr:modified ((,class :inherit modus-themes-fringe-yellow))) ;;;;; git-{gutter,fringe}+ `(git-gutter+-added ((,class :inherit ,@(modus-themes--diff-deuteran - 'modus-themes-fringe-blue - 'modus-themes-fringe-green)))) + 'modus-themes-fringe-blue + 'modus-themes-fringe-green)))) `(git-gutter+-deleted ((,class :inherit modus-themes-fringe-red))) `(git-gutter+-modified ((,class :inherit modus-themes-fringe-yellow))) `(git-gutter+-separator ((,class :inherit modus-themes-fringe-cyan))) @@ -5851,6 +5986,11 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; iflipb `(iflipb-current-buffer-face ((,class :inherit bold :foreground ,cyan-alt))) `(iflipb-other-buffer-face ((,class :inherit shadow))) +;;;;; image-dired + `(image-dired-thumb-flagged ((,class :background ,red-intense-bg))) + `(image-dired-thumb-mark ((,class :background ,@(modus-themes--success-deuteran + cyan-intense-bg + green-intense-bg)))) ;;;;; imenu-list `(imenu-list-entry-face-0 ((,class :foreground ,cyan))) `(imenu-list-entry-face-1 ((,class :foreground ,blue))) @@ -5862,7 +6002,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(imenu-list-entry-subalist-face-3 ((,class :inherit bold :foreground ,red-alt-other :underline t))) ;;;;; indium `(indium-breakpoint-face ((,class :foreground ,red-active))) - `(indium-frame-url-face ((,class :inherit button :foreground ,fg-alt))) + `(indium-frame-url-face ((,class :inherit (shadow button)))) `(indium-keyword-face ((,class :inherit font-lock-keyword-face))) `(indium-litable-face ((,class :inherit modus-themes-slant :foreground ,fg-special-warm))) `(indium-repl-error-face ((,class :inherit error))) @@ -5870,8 +6010,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(indium-repl-stdout-face ((,class :foreground ,fg-main))) ;;;;; info `(Info-quoted ((,class :inherit modus-themes-fixed-pitch ; the capitalization is canonical - :background ,bg-alt :foreground ,fg-special-calm))) - `(info-header-node ((,class :inherit bold :foreground ,fg-alt))) + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) + `(info-header-node ((,class :inherit (shadow bold)))) `(info-header-xref ((,class :foreground ,blue-active))) `(info-index-match ((,class :inherit match))) `(info-menu-header ((,class :inherit modus-themes-heading-3))) @@ -5882,7 +6023,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(info-title-3 ((,class :inherit modus-themes-heading-3))) `(info-title-4 ((,class :inherit modus-themes-heading-4))) ;;;;; info-colors - `(info-colors-lisp-code-block ((,class :inherit fixed-pitch))) + `(info-colors-lisp-code-block ((,class :inherit modus-themes-fixed-pitch))) `(info-colors-ref-item-command ((,class :inherit font-lock-function-name-face))) `(info-colors-ref-item-constant ((,class :inherit font-lock-constant-face))) `(info-colors-ref-item-function ((,class :inherit font-lock-function-name-face))) @@ -6089,7 +6230,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(lsp-face-semhl-variable ((,class :foreground ,cyan))) `(lsp-face-semhl-variable-local ((,class :foreground ,cyan))) `(lsp-face-semhl-variable-parameter ((,class :foreground ,cyan-alt-other))) - `(lsp-lens-face ((,class :height 0.8 :foreground ,fg-alt))) + `(lsp-lens-face ((,class :inherit shadow :height 0.8))) `(lsp-lens-mouse-face ((,class :height 0.8 :foreground ,blue-alt-other :underline t))) `(lsp-ui-doc-background ((,class :background ,bg-alt))) `(lsp-ui-doc-header ((,class :background ,bg-header :foreground ,fg-header))) @@ -6309,13 +6450,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markdown-html-tag-name-face ((,class :inherit modus-themes-fixed-pitch :foreground ,magenta-alt))) `(markdown-inline-code-face ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt :foreground ,fg-special-calm))) + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) `(markdown-italic-face ((,class :inherit italic))) `(markdown-language-info-face ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold))) `(markdown-language-keyword-face ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt - :foreground ,fg-alt))) + ,@(modus-themes--markup fg-alt red-alt + bg-alt red-nuanced-bg)))) `(markdown-line-break-face ((,class :inherit modus-themes-refine-cyan :underline t))) `(markdown-link-face ((,class :inherit button))) `(markdown-link-title-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold))) @@ -6349,7 +6491,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markup-meta-face ((,class :inherit shadow))) `(markup-meta-hide-face ((,class :foreground "gray50"))) `(markup-reference-face ((,class :foreground ,blue-alt :underline ,bg-region))) - `(markup-replacement-face ((,class :inherit fixed-pitch :foreground ,red-alt))) + `(markup-replacement-face ((,class :inherit modus-themes-fixed-pitch :foreground ,red-alt))) `(markup-secondary-text-face ((,class :height 0.9 :foreground ,cyan-alt-other))) `(markup-small-face ((,class :inherit markup-gen-face :height 0.9))) `(markup-strong-face ((,class :inherit markup-bold-face))) @@ -6479,7 +6621,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mu4e-title-face ((,class :foreground ,fg-main))) `(mu4e-trashed-face ((,class :foreground ,red))) `(mu4e-unread-face ((,class :inherit bold))) - `(mu4e-url-number-face ((,class :foreground ,fg-alt))) + `(mu4e-url-number-face ((,class :inherit shadow))) `(mu4e-view-body-face ((,class :foreground ,fg-main))) `(mu4e-warning-face ((,class :inherit warning))) ;;;;; mu4e-conversation @@ -6498,6 +6640,17 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mc/cursor-bar-face ((,class :height 1 :background ,fg-main))) `(mc/cursor-face ((,class :inverse-video t))) `(mc/region-face ((,class :inherit region))) +;;;;; nano-modeline + `(nano-modeline-active-primary ((,class :inherit mode-line :foreground ,fg-special-mild))) + `(nano-modeline-active-secondary ((,class :inherit mode-line :foreground ,fg-special-cold))) + `(nano-modeline-active-status-** ((,class :inherit mode-line :background ,yellow-subtle-bg))) + `(nano-modeline-active-status-RO ((,class :inherit mode-line :background ,red-subtle-bg))) + `(nano-modeline-active-status-RW ((,class :inherit mode-line :background ,cyan-subtle-bg))) + `(nano-modeline-inactive-primary ((,class :inherit mode-line-inactive :foreground ,fg-inactive))) + `(nano-modeline-inactive-secondary ((,class :inherit mode-line-inactive :foreground ,fg-inactive))) + `(nano-modeline-inactive-status-** ((,class :inherit mode-line-inactive :foreground ,yellow-active))) + `(nano-modeline-inactive-status-RO ((,class :inherit mode-line-inactive :foreground ,red-active))) + `(nano-modeline-inactive-status-RW ((,class :inherit mode-line-inactive :foreground ,cyan-active))) ;;;;; neotree `(neo-banner-face ((,class :foreground ,magenta))) `(neo-button-face ((,class :inherit button))) @@ -6507,7 +6660,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(neo-header-face ((,class :inherit bold :foreground ,fg-main))) `(neo-root-dir-face ((,class :inherit bold :foreground ,cyan-alt))) `(neo-vc-added-face ((,class :foreground ,@(modus-themes--diff-deuteran blue green)))) - `(neo-vc-conflict-face ((,class :inherit bold :foreground ,red))) + `(neo-vc-conflict-face ((,class :inherit error))) `(neo-vc-default-face ((,class :foreground ,fg-main))) `(neo-vc-edited-face ((,class :foreground ,yellow))) `(neo-vc-ignored-face ((,class :foreground ,fg-inactive))) @@ -6601,17 +6754,20 @@ by virtue of calling either of `modus-themes-load-operandi' and yellow-refine-bg yellow-refine-fg)))) ;;;;; org `(org-agenda-calendar-event ((,class ,@(modus-themes--agenda-event blue-alt)))) - `(org-agenda-calendar-sexp ((,class :inherit org-agenda-calendar-event))) + `(org-agenda-calendar-sexp ((,class ,@(modus-themes--agenda-event blue-alt t)))) `(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend t))) `(org-agenda-column-dateline ((,class :background ,bg-alt))) `(org-agenda-current-time ((,class :foreground ,blue-alt-other-faint))) `(org-agenda-date ((,class ,@(modus-themes--agenda-date cyan fg-main)))) - `(org-agenda-date-today ((,class ,@(modus-themes--agenda-date blue-active fg-main - cyan-active fg-main - bg-active t t)))) - `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other fg-alt + `(org-agenda-date-today ((,class ,@(modus-themes--agenda-date cyan fg-main + nil nil + bg-inactive t t)))) + `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt cyan fg-main)))) - `(org-agenda-diary ((,class :inherit org-agenda-calendar-event))) + `(org-agenda-date-weekend-today ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt + cyan fg-main + bg-inactive t t)))) + `(org-agenda-diary ((,class :inherit org-agenda-calendar-sexp))) `(org-agenda-dimmed-todo-face ((,class :inherit shadow))) `(org-agenda-done ((,class :foreground ,@(modus-themes--success-deuteran blue-nuanced-fg @@ -6622,6 +6778,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-agenda-filter-tags ((,class :inherit bold :foreground ,cyan-active))) `(org-agenda-restriction-lock ((,class :background ,bg-dim :foreground ,fg-dim))) `(org-agenda-structure ((,class ,@(modus-themes--agenda-structure blue-alt)))) + `(org-agenda-structure-filter ((,class :inherit org-agenda-structure :foreground ,yellow))) + `(org-agenda-structure-secondary ((,class :foreground ,cyan))) `(org-archived ((,class :background ,bg-alt :foreground ,fg-alt))) `(org-block ((,class :inherit modus-themes-fixed-pitch ,@(modus-themes--org-block bg-dim fg-main)))) @@ -6636,23 +6794,24 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-checkbox-statistics-todo ((,class :inherit org-todo))) `(org-clock-overlay ((,class :inherit modus-themes-special-cold))) `(org-code ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt :foreground ,fg-special-mild + ,@(modus-themes--markup fg-special-mild green-alt-other + bg-alt green-nuanced-bg) :extend t))) `(org-column ((,class :background ,bg-alt))) `(org-column-title ((,class :inherit bold :underline t :background ,bg-alt))) - `(org-date ((,class :inherit ,(if modus-themes-no-mixed-fonts - 'button - '(button fixed-pitch)) + `(org-date ((,class :inherit ,(if modus-themes-mixed-fonts + '(button fixed-pitch) + 'button) ,@(modus-themes--link-color cyan cyan-faint)))) `(org-date-selected ((,class :inherit bold :foreground ,blue-alt :inverse-video t))) `(org-dispatcher-highlight ((,class :inherit (bold modus-themes-mark-alt)))) `(org-document-info ((,class :foreground ,fg-special-cold))) - `(org-document-info-keyword ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + `(org-document-info-keyword ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-document-title ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,fg-special-cold ,@(modus-themes--scale modus-themes-scale-title)))) `(org-done ((,class :foreground ,@(modus-themes--success-deuteran blue green)))) - `(org-drawer ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + `(org-drawer ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-ellipsis (())) ; inherits from the heading's color `(org-footnote ((,class :inherit button ,@(modus-themes--link-color @@ -6701,6 +6860,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-headline-todo ((,class :inherit modus-themes-variable-pitch :foreground ,red-nuanced-fg))) `(org-hide ((,class :foreground ,bg-main))) `(org-indent ((,class :inherit (fixed-pitch org-hide)))) + `(org-imminent-deadline ((,class :foreground ,red-intense))) `(org-latex-and-related ((,class :foreground ,magenta-refine-fg))) `(org-level-1 ((,class :inherit modus-themes-heading-1))) `(org-level-2 ((,class :inherit modus-themes-heading-2))) @@ -6713,8 +6873,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-link ((,class :inherit button))) `(org-list-dt ((,class :inherit bold))) `(org-macro ((,class :inherit modus-themes-fixed-pitch - :background ,cyan-nuanced-bg :foreground ,cyan-nuanced-fg))) - `(org-meta-line ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + ,@(modus-themes--markup cyan-nuanced-fg cyan + cyan-nuanced-bg cyan-nuanced-bg)))) + `(org-meta-line ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-mode-line-clock ((,class :foreground ,fg-main))) `(org-mode-line-clock-overrun ((,class :inherit bold :foreground ,red-active))) `(org-priority ((,class :foreground ,magenta))) @@ -6724,18 +6885,19 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-scheduled-previously ((,class ,@(modus-themes--agenda-scheduled yellow fg-special-warm yellow-alt-other)))) `(org-scheduled-today ((,class ,@(modus-themes--agenda-scheduled yellow fg-special-warm magenta-alt-other)))) `(org-sexp-date ((,class :inherit org-date))) - `(org-special-keyword ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + `(org-special-keyword ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-table ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold))) `(org-table-header ((,class :inherit (fixed-pitch modus-themes-intense-neutral)))) `(org-tag ((,class :foreground ,magenta-nuanced-fg))) `(org-tag-group ((,class :inherit bold :foreground ,cyan-nuanced-fg))) `(org-target ((,class :underline t))) - `(org-time-grid ((,class :foreground ,fg-unfocused))) + `(org-time-grid ((,class :inherit shadow))) `(org-todo ((,class :foreground ,red))) `(org-upcoming-deadline ((,class :foreground ,red-alt-other))) `(org-upcoming-distant-deadline ((,class :foreground ,red-faint))) `(org-verbatim ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt :foreground ,fg-special-calm))) + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) `(org-verse ((,class :inherit org-quote))) `(org-warning ((,class :inherit bold :foreground ,red-alt-other))) ;;;;; org-journal @@ -6764,7 +6926,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-roam-link-shielded ((,class :inherit button ,@(modus-themes--link-color yellow yellow-faint)))) - `(org-roam-tag ((,class :inherit italic :foreground ,fg-alt))) + `(org-roam-tag ((,class :inherit (shadow italic)))) ;;;;; org-superstar `(org-superstar-item ((,class :foreground ,fg-main))) `(org-superstar-leading ((,class :foreground ,fg-whitespace))) @@ -6863,7 +7025,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; pomidor `(pomidor-break-face ((,class :foreground ,blue-alt-other))) `(pomidor-overwork-face ((,class :foreground ,red-alt-other))) - `(pomidor-skip-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) + `(pomidor-skip-face ((,class :inherit (shadow modus-themes-slant)))) `(pomidor-work-face ((,class :foreground ,@(modus-themes--success-deuteran blue-alt green-alt-other)))) @@ -6914,7 +7076,7 @@ by virtue of calling either of `modus-themes-load-operandi' and :foreground ,green))) `(racket-here-string-face ((,class :foreground ,blue-alt))) `(racket-keyword-argument-face ((,class :foreground ,red-alt))) - `(racket-logger-config-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) + `(racket-logger-config-face ((,class :inherit (shadow modus-themes-slant)))) `(racket-logger-debug-face ((,class :foreground ,blue-alt-other))) `(racket-logger-info-face ((,class :foreground ,fg-lang-note))) `(racket-logger-topic-face ((,class :inherit modus-themes-slant :foreground ,magenta))) @@ -7208,7 +7370,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(spray-base-face ((,class :inherit default :foreground ,fg-special-cold))) ;;;;; stripes `(stripes ((,class :background ,bg-alt))) -;;;;; success +;;;;; suggest `(suggest-heading ((,class :inherit bold :foreground ,yellow-alt-other))) ;;;;; switch-window `(switch-window-background ((,class :background ,bg-dim))) @@ -7255,7 +7417,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(sx-question-mode-score-downvoted ((,class :foreground ,yellow))) `(sx-question-mode-score-upvoted ((,class :inherit bold :foreground ,magenta))) `(sx-question-mode-title ((,class :inherit bold :foreground ,fg-main))) - `(sx-question-mode-title-comments ((,class :inherit bold :foreground ,fg-alt))) + `(sx-question-mode-title-comments ((,class :inherit (shadow bold)))) `(sx-tag ((,class :foreground ,magenta-alt))) `(sx-user-name ((,class :foreground ,blue-alt))) `(sx-user-reputation ((,class :inherit shadow))) @@ -7318,9 +7480,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(telega-button-active ((,class :box ,blue-intense-bg :background ,blue-intense-bg :foreground ,fg-main))) `(telega-button-highlight ((,class :inherit modus-themes-subtle-magenta))) `(telega-chat-prompt ((,class :inherit bold))) - `(telega-entity-type-code ((,class :inherit fixed-pitch))) + `(telega-entity-type-code ((,class :inherit modus-themes-fixed-pitch))) `(telega-entity-type-mention ((,class :foreground ,cyan))) - `(telega-entity-type-pre ((,class :inherit fixed-pitch))) + `(telega-entity-type-pre ((,class :inherit modus-themes-fixed-pitch))) `(telega-msg-heading ((,class :background ,bg-alt))) `(telega-msg-self-title ((,class :inherit bold))) `(telega-root-heading ((,class :inherit modus-themes-subtle-neutral))) @@ -7329,9 +7491,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(telega-user-online-status ((,class :foreground ,cyan-active))) `(telega-username ((,class :foreground ,cyan-alt-other))) `(telega-webpage-chat-link ((,class :background ,bg-alt))) - `(telega-webpage-fixed ((,class :inherit fixed-pitch :height 0.85))) + `(telega-webpage-fixed ((,class :inherit modus-themes-fixed-pitch :height 0.85))) `(telega-webpage-header ((,class :inherit modus-themes-variable-pitch :height 1.3))) - `(telega-webpage-preformatted ((,class :inherit fixed-pitch :background ,bg-alt))) + `(telega-webpage-preformatted ((,class :inherit modus-themes-fixed-pitch :background ,bg-alt))) `(telega-webpage-subheader ((,class :inherit modus-themes-variable-pitch :height 1.15))) ;;;;; telephone-line `(telephone-line-accent-active ((,class :background ,fg-inactive :foreground ,bg-inactive))) @@ -7383,10 +7545,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(transient-heading ((,class :inherit bold :foreground ,fg-main))) `(transient-inactive-argument ((,class :inherit shadow))) `(transient-inactive-value ((,class :inherit shadow))) - ;; FIXME 2021-08-28: using `modus-themes-key-binding' leads to - ;; misalignments because of the added box property. - ;; `(transient-key ((,class :inherit modus-themes-key-binding))) - `(transient-key ((,class :inherit bold :foreground ,blue-alt-other))) + `(transient-key ((,class :inherit modus-themes-key-binding))) `(transient-mismatched-key ((,class :underline t))) `(transient-nonstandard-key ((,class :underline t))) `(transient-pink ((,class :inherit bold :foreground ,magenta-alt-faint))) @@ -7473,10 +7632,10 @@ by virtue of calling either of `modus-themes-load-operandi' and `(vc-dir-header-value ((,class :foreground ,magenta-alt-other))) `(vc-dir-mark-indicator ((,class :foreground ,blue-alt-other))) `(vc-dir-status-edited ((,class :foreground ,yellow))) - `(vc-dir-status-ignored ((,class :foreground ,fg-unfocused))) + `(vc-dir-status-ignored ((,class :inherit shadow))) `(vc-dir-status-up-to-date ((,class :foreground ,cyan))) - `(vc-dir-status-warning ((,class :foreground ,red))) - `(vc-conflict-state ((,class :inherit modus-themes-slant :foreground ,red-active))) + `(vc-dir-status-warning ((,class :inherit error))) + `(vc-conflict-state ((,class :inherit bold :foreground ,red-active))) `(vc-edited-state ((,class :foreground ,yellow-active))) `(vc-locally-added-state ((,class :foreground ,cyan-active))) `(vc-locked-state ((,class :foreground ,blue-active))) @@ -7498,6 +7657,9 @@ by virtue of calling either of `modus-themes-load-operandi' and :background ,@(pcase modus-themes-completions ('opinionated (list bg-active)) (_ (list bg-inactive)))))) +;;;;; vertico-quick + `(vertico-quick1 ((,class :inherit (modus-themes-intense-magenta bold)))) + `(vertico-quick2 ((,class :inherit (modus-themes-refine-cyan bold)))) ;;;;; vimish-fold `(vimish-fold-fringe ((,class :foreground ,cyan-active))) `(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue))) diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 919009278b1..6dffbf07e94 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -4,8 +4,8 @@ ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Package-Requires: ((emacs "26.1")) +;; Version: 1.7.0 +;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in index e6cda733679..d062e78366f 100644 --- a/lib-src/Makefile.in +++ b/lib-src/Makefile.in @@ -27,7 +27,9 @@ EMACSOPT = -batch --no-site-file --no-site-lisp # ==================== Things 'configure' will edit ==================== CC=@CC@ +CXX=@CXX@ CFLAGS=@CFLAGS@ +CXXFLAGS=@CXXFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ @@ -130,6 +132,11 @@ MKDIR_P = @MKDIR_P@ # ========================== Lists of Files =========================== +## Haiku build-time support +HAVE_BE_APP=@HAVE_BE_APP@ +HAIKU_LIBS=@HAIKU_LIBS@ +HAIKU_CFLAGS=@HAIKU_CFLAGS@ + # emacsclientw.exe for MinGW, empty otherwise CLIENTW = @CLIENTW@ @@ -143,7 +150,11 @@ UTILITIES = hexl${EXEEXT} \ $(if $(with_mailutils), , movemail${EXEEXT}) \ $(and $(use_gamedir), update-game-score${EXEEXT}) +ifeq ($(HAVE_BE_APP),yes) +DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT} be-resources +else DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT} +endif # Like UTILITIES, but they're not system-dependent, and should not be # deleted by the distclean target. @@ -230,6 +241,10 @@ WINDRES = @WINDRES@ ## Some systems define this to request special libraries. LIBS_SYSTEM = @LIBS_SYSTEM@ +# Flags that could be in WARN_CFLAGS, but are invalid for C++. +NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \ + -Wstrict-prototypes -Wno-override-init + BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ -I. -I../src -I../lib \ @@ -238,6 +253,9 @@ BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \ ALL_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} CPP_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${CPPFLAGS} ${CFLAGS} +ALL_CXXFLAGS = $(filter-out ${NON_CXX_CFLAGS},${BASE_CFLAGS}) \ + ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} ${CXXFLAGS} ${HAIKU_CFLAGS} + # Configuration files for .o files to depend on. config_h = ../src/config.h $(srcdir)/../src/conf_post.h @@ -407,6 +425,9 @@ emacsclientw${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(CLIENTRES) $(config_h) $(LOADLIBES) \ $(LIB_WSOCK32) $(LIB_EACCESS) $(LIBS_ECLIENT) -o $@ +be-resources: ${srcdir}/be_resources.cc ${config_h} + $(AM_V_CXXLD)$(CXX) ${ALL_CXXFLAGS} ${HAIKU_LIBS} $< -o $@ + NTINC = ${srcdir}/../nt/inc NTDEPS = $(NTINC)/ms-w32.h $(NTINC)/sys/stat.h $(NTINC)/inttypes.h \ $(NTINC)/stdint.h $(NTINC)/pwd.h $(NTINC)/sys/time.h $(NTINC)/stdbool.h \ diff --git a/lib-src/be_resources.cc b/lib-src/be_resources.cc new file mode 100644 index 00000000000..e6a14f037b6 --- /dev/null +++ b/lib-src/be_resources.cc @@ -0,0 +1,144 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +using namespace std; + +static void +be_perror (status_t code, char *arg) +{ + if (code != B_OK) + { + switch (code) + { + case B_BAD_VALUE: + fprintf (stderr, "%s: Bad value\n", arg); + break; + case B_ENTRY_NOT_FOUND: + fprintf (stderr, "%s: Not found\n", arg); + break; + case B_PERMISSION_DENIED: + fprintf (stderr, "%s: Permission denied\n", arg); + break; + case B_NO_MEMORY: + fprintf (stderr, "%s: No memory\n", arg); + break; + case B_LINK_LIMIT: + fprintf (stderr, "%s: Link limit reached\n", arg); + break; + case B_BUSY: + fprintf (stderr, "%s: Busy\n", arg); + break; + case B_NO_MORE_FDS: + fprintf (stderr, "%s: No more file descriptors\n", arg); + break; + case B_FILE_ERROR: + fprintf (stderr, "%s: File error\n", arg); + break; + default: + fprintf (stderr, "%s: Unknown error\n", arg); + } + } + else + { + abort (); + } +} + +int +main (int argc, char **argv) +{ + BApplication app ("application/x-vnd.GNU-emacs-resource-helper"); + BFile file; + BBitmap *icon; + BAppFileInfo info; + status_t code; + struct version_info vinfo; + char *v = strdup (PACKAGE_VERSION); + + if (argc != 3) + { + printf ("be-resources ICON FILE: make FILE appropriate for Emacs.\n"); + return EXIT_FAILURE; + } + + code = file.SetTo (argv[2], B_READ_WRITE); + if (code != B_OK) + { + be_perror (code, argv[2]); + return EXIT_FAILURE; + } + code = info.SetTo (&file); + if (code != B_OK) + { + be_perror (code, argv[2]); + return EXIT_FAILURE; + } + code = info.SetAppFlags (B_EXCLUSIVE_LAUNCH | B_ARGV_ONLY); + if (code != B_OK) + { + be_perror (code, argv[2]); + return EXIT_FAILURE; + } + + icon = BTranslationUtils::GetBitmapFile (argv[1], NULL); + + if (!icon) + { + be_perror (B_ERROR, argv[1]); + return EXIT_FAILURE; + } + + info.SetIcon (icon, B_MINI_ICON); + info.SetIcon (icon, B_LARGE_ICON); + info.SetSignature ("application/x-vnd.GNU-emacs"); + + v = strtok (v, "."); + vinfo.major = atoi (v); + + v = strtok (NULL, "."); + vinfo.middle = atoi (v); + + v = strtok (NULL, "."); + vinfo.minor = v ? atoi (v) : 0; + + vinfo.variety = 0; + vinfo.internal = 0; + + strncpy ((char *) &vinfo.short_info, PACKAGE_VERSION, + sizeof vinfo.short_info - 1); + strncpy ((char *) &vinfo.long_info, PACKAGE_STRING, + sizeof vinfo.long_info - 1); + + info.SetVersionInfo (&vinfo, B_APP_VERSION_KIND); + + return EXIT_SUCCESS; +} diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 1f3e72f81db..bdf228aeaa9 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -603,6 +603,8 @@ decode_options (int argc, char **argv) alt_display = "ns"; #elif defined (HAVE_NTGUI) alt_display = "w32"; +#elif defined (HAVE_HAIKU) + alt_display = "be"; #endif #ifdef HAVE_PGTK diff --git a/lisp/abbrev.el b/lisp/abbrev.el index d3daf637cc6..386aff16270 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -403,7 +403,7 @@ argument." (defun expand-region-abbrevs (start end &optional noquery) "For abbrev occurrence in the region, offer to expand it. -The user is asked to type `y' or `n' for each occurrence. +The user is asked to type \\`y' or \\`n' for each occurrence. A prefix argument means don't query; expand all abbrevs." (interactive "r\nP") (save-excursion diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index 2e51264ec39..c962cbd4780 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -91,7 +91,7 @@ as a PDF file." :group 'processes) (defface ansi-color-bold - '((t :inherit 'bold)) + '((t :inherit bold)) "Face used to render bold text." :group 'ansi-colors :version "28.1") @@ -103,13 +103,13 @@ as a PDF file." :version "28.1") (defface ansi-color-italic - '((t :inherit 'italic)) + '((t :inherit italic)) "Face used to render italic text." :group 'ansi-colors :version "28.1") (defface ansi-color-underline - '((t :inherit 'underline)) + '((t :inherit underline)) "Face used to render underlined text." :group 'ansi-colors :version "28.1") diff --git a/lisp/bindings.el b/lisp/bindings.el index 121e484a0ee..e28b06a1dcd 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -501,8 +501,9 @@ mouse-1: Display Line and Column Mode Menu")) (defvar mode-line-position `((:propertize - mode-line-percent-position + (" " mode-line-percent-position) local-map ,mode-line-column-line-number-mode-map + display (min-width (5.0)) mouse-face mode-line-highlight ;; XXX needs better description help-echo "Window Scroll Percentage @@ -521,26 +522,31 @@ mouse-1: Display Line and Column Mode Menu"))) (10 (:propertize mode-line-position-column-line-format + display (min-width (10.0)) ,@mode-line-position--column-line-properties)) (10 (:propertize (:eval (string-replace "%c" "%C" (car mode-line-position-column-line-format))) + display (min-width (10.0)) ,@mode-line-position--column-line-properties))) (6 (:propertize mode-line-position-line-format + display (min-width (6.0)) ,@mode-line-position--column-line-properties)))) (column-number-mode (column-number-indicator-zero-based (6 (:propertize mode-line-position-column-format + display (min-width (6.0)) (,@mode-line-position--column-line-properties))) (6 (:propertize (:eval (string-replace "%c" "%C" (car mode-line-position-column-format))) + display (min-width (6.0)) ,@mode-line-position--column-line-properties)))))) "Mode line construct for displaying the position in the buffer. Normally displays the buffer percentage and, optionally, the @@ -597,10 +603,14 @@ By default, this shows the information specified by `global-mode-string'.") (let ((standard-mode-line-format (list "%e" 'mode-line-front-space - 'mode-line-mule-info - 'mode-line-client - 'mode-line-modified - 'mode-line-remote + (list + :propertize + (list "" + 'mode-line-mule-info + 'mode-line-client + 'mode-line-modified + 'mode-line-remote) + 'display '(min-width (5.0))) 'mode-line-frame-identification 'mode-line-buffer-identification " " diff --git a/lisp/bookmark.el b/lisp/bookmark.el index a4c28e751ca..a8fa9ae7749 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -214,31 +214,28 @@ A non-nil value may result in truncated bookmark names." ;;;###autoload (define-key ctl-x-r-map "l" 'bookmark-bmenu-list) ;;;###autoload -(defvar bookmark-map - (let ((map (make-sparse-keymap))) - ;; Read the help on all of these functions for details... - (define-key map "x" 'bookmark-set) - (define-key map "m" 'bookmark-set) ;"m"ark - (define-key map "M" 'bookmark-set-no-overwrite) ;"M"aybe mark - (define-key map "j" 'bookmark-jump) - (define-key map "g" 'bookmark-jump) ;"g"o - (define-key map "o" 'bookmark-jump-other-window) - (define-key map "5" 'bookmark-jump-other-frame) - (define-key map "i" 'bookmark-insert) - (define-key map "e" 'edit-bookmarks) - (define-key map "f" 'bookmark-insert-location) ;"f"ind - (define-key map "r" 'bookmark-rename) - (define-key map "d" 'bookmark-delete) - (define-key map "D" 'bookmark-delete-all) - (define-key map "l" 'bookmark-load) - (define-key map "w" 'bookmark-write) - (define-key map "s" 'bookmark-save) - map) - "Keymap containing bindings to bookmark functions. +(defvar-keymap bookmark-map + :doc "Keymap containing bindings to bookmark functions. It is not bound to any key by default: to bind it so that you have a bookmark prefix, just use `global-set-key' and bind a key of your choice to variable `bookmark-map'. All interactive bookmark -functions have a binding in this keymap.") +functions have a binding in this keymap." + "x" #'bookmark-set + "m" #'bookmark-set ;"m"ark + "M" #'bookmark-set-no-overwrite ;"M"aybe mark + "j" #'bookmark-jump + "g" #'bookmark-jump ;"g"o + "o" #'bookmark-jump-other-window + "5" #'bookmark-jump-other-frame + "i" #'bookmark-insert + "e" #'edit-bookmarks + "f" #'bookmark-insert-location ;"f"ind + "r" #'bookmark-rename + "d" #'bookmark-delete + "D" #'bookmark-delete-all + "l" #'bookmark-load + "w" #'bookmark-write + "s" #'bookmark-save) ;;;###autoload (fset 'bookmark-map bookmark-map) @@ -479,7 +476,10 @@ See user option `bookmark-set-fringe'." (dolist (buf (buffer-list)) (with-current-buffer buf (when (equal filename buffer-file-name) - (setq overlays (overlays-in pos (1+ pos))) + (setq overlays + (save-excursion + (goto-char pos) + (overlays-in (point-at-bol) (1+ (point-at-bol))))) (while (and (not found) (setq temp (pop overlays))) (when (eq 'bookmark (overlay-get temp 'category)) (delete-overlay (setq found temp)))))))))) @@ -810,11 +810,9 @@ CODING is the symbol of the coding-system in which the file is encoded." (define-obsolete-function-alias 'bookmark-maybe-message 'message "27.1") -(defvar bookmark-minibuffer-read-name-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-w" 'bookmark-yank-word) - map)) +(defvar-keymap bookmark-minibuffer-read-name-map + :parent minibuffer-local-map + "C-w" #'bookmark-yank-word) (defun bookmark-set-internal (prompt name overwrite-or-push) "Set a bookmark using specified NAME or prompting with PROMPT. @@ -918,7 +916,7 @@ it removes only the first instance of a bookmark with that name from the list of bookmarks.)" (interactive (list nil current-prefix-arg)) (let ((prompt - (if no-overwrite "Set bookmark" "Set bookmark unconditionally"))) + (if no-overwrite "Append bookmark named" "Set bookmark named"))) (bookmark-set-internal prompt name (if no-overwrite 'push 'overwrite)))) ;;;###autoload @@ -989,12 +987,10 @@ annotations." "Function to return default text to use for a bookmark annotation. It takes one argument, the name of the bookmark, as a string.") -(defvar bookmark-edit-annotation-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\C-c\C-c" 'bookmark-send-edited-annotation) - map) - "Keymap for editing an annotation of a bookmark.") +(defvar-keymap bookmark-edit-annotation-mode-map + :doc "Keymap for editing an annotation of a bookmark." + :parent text-mode-map + "C-c C-c" #'bookmark-send-edited-annotation) (defun bookmark-insert-annotation (bookmark-name-or-record) "Insert annotation for BOOKMARK-NAME-OR-RECORD at point." @@ -1697,44 +1693,42 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (defvar bookmark-bmenu-hidden-bookmarks ()) - -(defvar bookmark-bmenu-mode-map - (let ((map (make-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "v" 'bookmark-bmenu-select) - (define-key map "w" 'bookmark-bmenu-locate) - (define-key map "5" 'bookmark-bmenu-other-frame) - (define-key map "2" 'bookmark-bmenu-2-window) - (define-key map "1" 'bookmark-bmenu-1-window) - (define-key map "j" 'bookmark-bmenu-this-window) - (define-key map "\C-c\C-c" 'bookmark-bmenu-this-window) - (define-key map "f" 'bookmark-bmenu-this-window) - (define-key map "\C-m" 'bookmark-bmenu-this-window) - (define-key map "o" 'bookmark-bmenu-other-window) - (define-key map "\C-o" 'bookmark-bmenu-switch-other-window) - (define-key map "s" 'bookmark-bmenu-save) - (define-key map "\C-x\C-s" 'bookmark-bmenu-save) - (define-key map "k" 'bookmark-bmenu-delete) - (define-key map "\C-d" 'bookmark-bmenu-delete-backwards) - (define-key map "x" 'bookmark-bmenu-execute-deletions) - (define-key map "d" 'bookmark-bmenu-delete) - (define-key map "D" 'bookmark-bmenu-delete-all) - (define-key map " " 'next-line) - (define-key map "\177" 'bookmark-bmenu-backup-unmark) - (define-key map "u" 'bookmark-bmenu-unmark) - (define-key map "U" 'bookmark-bmenu-unmark-all) - (define-key map "m" 'bookmark-bmenu-mark) - (define-key map "M" 'bookmark-bmenu-mark-all) - (define-key map "l" 'bookmark-bmenu-load) - (define-key map "r" 'bookmark-bmenu-rename) - (define-key map "R" 'bookmark-bmenu-relocate) - (define-key map "t" 'bookmark-bmenu-toggle-filenames) - (define-key map "a" 'bookmark-bmenu-show-annotation) - (define-key map "A" 'bookmark-bmenu-show-all-annotations) - (define-key map "e" 'bookmark-bmenu-edit-annotation) - (define-key map "/" 'bookmark-bmenu-search) - (define-key map [mouse-2] 'bookmark-bmenu-other-window-with-mouse) - map)) +(defvar-keymap bookmark-bmenu-mode-map + :doc "Keymap for `bookmark-bmenu-mode'." + :parent tabulated-list-mode-map + "v" #'bookmark-bmenu-select + "w" #'bookmark-bmenu-locate + "5" #'bookmark-bmenu-other-frame + "2" #'bookmark-bmenu-2-window + "1" #'bookmark-bmenu-1-window + "j" #'bookmark-bmenu-this-window + "C-c C-c" #'bookmark-bmenu-this-window + "f" #'bookmark-bmenu-this-window + "C-m" #'bookmark-bmenu-this-window + "o" #'bookmark-bmenu-other-window + "C-o" #'bookmark-bmenu-switch-other-window + "s" #'bookmark-bmenu-save + "C-x C-s" #'bookmark-bmenu-save + "k" #'bookmark-bmenu-delete + "C-d" #'bookmark-bmenu-delete-backwards + "x" #'bookmark-bmenu-execute-deletions + "d" #'bookmark-bmenu-delete + "D" #'bookmark-bmenu-delete-all + "SPC" #'next-line + "DEL" #'bookmark-bmenu-backup-unmark + "u" #'bookmark-bmenu-unmark + "U" #'bookmark-bmenu-unmark-all + "m" #'bookmark-bmenu-mark + "M" #'bookmark-bmenu-mark-all + "l" #'bookmark-bmenu-load + "r" #'bookmark-bmenu-rename + "R" #'bookmark-bmenu-relocate + "t" #'bookmark-bmenu-toggle-filenames + "a" #'bookmark-bmenu-show-annotation + "A" #'bookmark-bmenu-show-all-annotations + "e" #'bookmark-bmenu-edit-annotation + "/" #'bookmark-bmenu-search + "" #'bookmark-bmenu-other-window-with-mouse) (easy-menu-define bookmark-menu bookmark-bmenu-mode-map "Menu for `bookmark-bmenu'." diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 7891e35c40f..b6ee124a72f 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -969,7 +969,8 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (define-key calc-dumb-map "\C-c\C-c" 'exit-recursive-edit))) (use-local-map calc-dumb-map) (setq truncate-lines t) - (message "Type `q' or `C-c C-c' to return to Calc") + (message (substitute-command-keys + "Type \\`q' or \\`C-c C-c' to return to Calc")) (recursive-edit) (bury-buffer "*Gnuplot Trail*"))) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index 8481d0b5e9d..2633d64fe42 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -50,25 +50,25 @@ (beep)))) (defun calc-help-for-help (arg) - "You have typed `h', the Calc help character. Type a Help option: + "You have typed \\`h', the Calc help character. Type a Help option: -B calc-describe-bindings. Display a table of all key bindings. -H calc-full-help. Display all `?' key messages at once. +\\`B' calc-describe-bindings. Display a table of all key bindings. +\\`H' calc-full-help. Display all \\`?' key messages at once. -I calc-info. Read the Calc manual using the Info system. -T calc-tutorial. Read the Calc tutorial using the Info system. -S calc-info-summary. Read the Calc summary using the Info system. +\\`I' calc-info. Read the Calc manual using the Info system. +\\`T' calc-tutorial. Read the Calc tutorial using the Info system. +\\`S' calc-info-summary. Read the Calc summary using the Info system. -C calc-describe-key-briefly. Look up the command name for a given key. -K calc-describe-key. Look up a key's documentation in the manual. -F calc-describe-function. Look up a function's documentation in the manual. -V calc-describe-variable. Look up a variable's documentation in the manual. +\\`C' calc-describe-key-briefly. Look up the command name for a given key. +\\`K' calc-describe-key. Look up a key's documentation in the manual. +\\`F' calc-describe-function. Look up a function's documentation in the manual. +\\`V' calc-describe-variable. Look up a variable's documentation in the manual. -N calc-view-news. Display Calc history of changes. +\\`N' calc-view-news. Display Calc history of changes. -C-c Describe conditions for copying Calc. -C-d Describe how you can get a new copy of Calc or report a bug. -C-w Describe how there is no warranty for Calc." +\\`C-c' Describe conditions for copying Calc. +\\`C-d' Describe how you can get a new copy of Calc or report a bug. +\\`C-w' Describe how there is no warranty for Calc." (interactive "P") (if calc-dispatch-help (let (key) diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index c8394e8c2fa..1c4438e7f7a 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -216,26 +216,28 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C)." (defun calc-help () (interactive) (let ((msgs - '("Press `h' for complete help; press `?' repeatedly for a summary" - "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" - "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" - "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" - "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" - "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" - "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" - "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" - "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" - "Other keys: SPC/RET (enter/dup), LFD (over); < > (scroll horiz)" - "Other keys: DEL (drop), M-DEL (drop-above); { } (scroll vert)" - "Other keys: TAB (swap/roll-dn), M-TAB (roll-up)" - "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" - "Prefix keys: Algebra, Binary/business, Convert, Display" - "Prefix keys: Functions, Graphics, Help, J (select)" - "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" - "Prefix keys: Trail/time, Units/statistics, Vector/matrix" - "Prefix keys: Z (user), SHIFT + Z (define)" - "Prefix keys: prefix + ? gives further help for that prefix" - " Calc by Dave Gillespie, daveg@synaptics.com"))) + ;; FIXME: Change these to `substitute-command-keys' syntax. + (mapcar #'substitute-command-keys + '("Press \\`h' for complete help; press \\`?' repeatedly for a summary" + "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" + "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" + "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" + "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" + "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" + "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" + "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" + "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" + "Other keys: \\`SPC'/\\`RET' (enter/dup), LFD (over); < > (scroll horiz)" + "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); { } (scroll vert)" + "Other keys: \\`TAB' (swap/roll-dn), \\`M-TAB' (roll-up)" + "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" + "Prefix keys: Algebra, Binary/business, Convert, Display" + "Prefix keys: Functions, Graphics, Help, J (select)" + "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" + "Prefix keys: Trail/time, Units/statistics, Vector/matrix" + "Prefix keys: Z (user), SHIFT + Z (define)" + "Prefix keys: prefix + ? gives further help for that prefix" + " Calc by Dave Gillespie, daveg@synaptics.com")))) (if calc-full-help-flag msgs (if (or calc-inverse-flag calc-hyperbolic-flag) diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index 68c8b90ac3b..211b8e661fd 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -109,11 +109,14 @@ (setq n (and (not (eq calc-auto-why t)) (if calc-auto-why t 1)))) (calc-change-mode 'calc-auto-why n nil) (cond ((null n) - (message "User must press `w' to explain unsimplified results")) + (message (substitute-command-keys + "User must press \\`w' to explain unsimplified results"))) ((eq n t) - (message "Automatically doing `w' to explain unsimplified results")) + (message (substitute-command-keys + "Automatically doing \\`w' to explain unsimplified results"))) (t - (message "Automatically doing `w' only for unusual messages"))))) + (message (substitute-command-keys + "Automatically doing \\`w' only for unusual messages")))))) (defun calc-group-digits (n) (interactive "P") diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index bd4ec4ff2f0..9774ddff402 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1621,7 +1621,8 @@ See calc-keypad for details." (stringp (nth 1 err)) (string-match "max-specpdl-size\\|max-lisp-eval-depth" (nth 1 err))) - (error "Computation got stuck or ran too long. Type `M' to increase the limit") + (error (substitute-command-keys + "Computation got stuck or ran too long. Type \\`M' to increase the limit")) (setq calc-aborted-prefix nil) (signal (car err) (cdr err))))) (when calc-aborted-prefix diff --git a/lisp/calculator.el b/lisp/calculator.el index 6bcea2d885e..0c255c0cf9d 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -593,15 +593,15 @@ except when using a non-decimal radix mode for input (in this case `e' will be the hexadecimal digit). Here are the editing keys: -* `RET' `=' evaluate the current expression -* `C-insert' copy the whole current expression to the `kill-ring' -* `C-return' evaluate, save result the `kill-ring' and exit -* `insert' paste a number if the one was copied (normally) -* `delete' `C-d' clear last argument or whole expression (hit twice) -* `backspace' delete a digit or a previous expression element -* `h' `?' pop-up a quick reference help -* `ESC' `q' exit (`ESC' can be used if `calculator-bind-escape' is - non-nil, otherwise use three consecutive `ESC's) +* \\`RET' \\`=' evaluate the current expression +* \\`C-' copy the whole current expression to the `kill-ring' +* \\`C-' evaluate, save result the `kill-ring' and exit +* \\`' paste a number if the one was copied (normally) +* \\`' \\`C-d' clear last argument or whole expression (hit twice) +* \\`' delete a digit or a previous expression element +* \\`h' \\`?' pop-up a quick reference help +* \\`ESC' \\`q' exit (\\`ESC' can be used if `calculator-bind-escape' is + non-nil, otherwise use three consecutive \\`ESC's) These operators are pre-defined: * `+' `-' `*' `/' the common binary operators @@ -623,10 +623,10 @@ argument. hex/oct/bin modes can be set for input and for display separately. Another toggle-able mode is for using degrees instead of radians for trigonometric functions. -The keys to switch modes are (both `H' and `X' are for hex): -* `D' switch to all-decimal mode, or toggle degrees/radians -* `B' `O' `H' `X' binary/octal/hexadecimal modes for input & display -* `i' `o' followed by one of `D' `B' `O' `H' `X' (case +The keys to switch modes are (both \\`H' and \\`X' are for hex): +* \\`D' switch to all-decimal mode, or toggle degrees/radians +* \\`B' \\`O' \\`H' \\`X' binary/octal/hexadecimal modes for input & display +* \\`i' \\`o' followed by one of \\`D' \\`B' \\`O' \\`H' \\`X' (case insensitive) sets only the input or display radix mode The prompt indicates the current modes: * \"==\": decimal mode (using radians); @@ -649,17 +649,17 @@ collected data. It is possible to navigate in this list, and if the value shown is the current one on the list, an indication is displayed as \"[N]\" if this is the last number and there are N numbers, or \"[M/N]\" if the M-th value is shown. -* `SPC' evaluate the current value as usual, but also adds +* \\`SPC' evaluate the current value as usual, but also adds the result to the list of saved values -* `l' `v' computes total / average of saved values -* `up' `C-p' browse to the previous value in the list -* `down' `C-n' browse to the next value in the list -* `delete' `C-d' remove current value from the list (if it is on it) -* `C-delete' `C-c' delete the whole list +* \\`l' \\`v' computes total / average of saved values +* \\`' \\`C-p' browse to the previous value in the list +* \\`' \\`C-n' browse to the next value in the list +* \\`' \\`C-d' remove current value from the list (if it is on it) +* \\`C-' \\`C-c' delete the whole list Registers are variable-like place-holders for values: -* `s' followed by a character attach the current value to that character -* `g' followed by a character fetches the attached value +* \\`s' followed by a character attach the current value to that character +* \\`g' followed by a character fetches the attached value There are many variables that can be used to customize the calculator. Some interesting customization variables are: diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 2d31101e50e..7a483d40627 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -644,13 +644,13 @@ FIXME: multiple comma-separated values should be allowed!" ;; seconds present (setq second (read (substring isodatetimestring 13 15)))) ;; FIXME: Support subseconds. - (when (and (> (length isodatetimestring) 15) - ;; UTC specifier present - (char-equal ?Z (aref isodatetimestring 15))) - (setq source-zone t - ;; decode to local time unless result-zone is explicitly given, - ;; i.e. do not decode to UTC, i.e. do not (setq result-zone t) - )) + (when (> (length isodatetimestring) 15) + (cl-case (aref isodatetimestring 15) + (?Z + (setq source-zone t)) + ((?- ?+) + (setq source-zone + (concat "UTC" (substring isodatetimestring 15)))))) ;; shift if necessary (if day-shift (let ((mdy (calendar-gregorian-from-absolute diff --git a/lisp/cedet/semantic/symref/cscope.el b/lisp/cedet/semantic/symref/cscope.el index e63b7a7e914..bc3f4a248b7 100644 --- a/lisp/cedet/semantic/symref/cscope.el +++ b/lisp/cedet/semantic/symref/cscope.el @@ -43,7 +43,7 @@ the hit list. See the function `cedet-cscope-search' for more details.") (cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-cscope)) - "Perform a search with GNU Global." + "Perform a search with CScope." (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode) (ede-toplevel))) (default-directory (if rootproj diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index f91a7e228ed..ae71140e262 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -2176,7 +2176,7 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns pgtk) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." @@ -2184,7 +2184,7 @@ and `face'." :group 'custom-faces) (defface custom-button-mouse - '((((type x w32 ns pgtk) (class color)) + '((((type x w32 ns haiku pgtk) (class color)) :box (:line-width 2 :style released-button) :background "grey90" :foreground "black") (t @@ -2209,7 +2209,7 @@ and `face'." (if custom-raised-buttons 'custom-button-mouse 'highlight)) (defface custom-button-pressed - '((((type x w32 ns pgtk) (class color)) + '((((type x w32 ns haiku pgtk) (class color)) :box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black") (t :inverse-video t)) @@ -4650,8 +4650,8 @@ You can set this option through Custom, if you carefully read the last paragraph below. However, usually it is simpler to write something like the following in your init file: -\(setq custom-file \"~/.emacs-custom.el\") -\(load custom-file) +(setq custom-file \"~/.config/emacs-custom.el\") +(load custom-file) Note that both lines are necessary: the first line tells Custom to save all customizations in this file, but does not load it. diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 5037ee77c7c..c78a327fdfa 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -54,6 +54,7 @@ (string :tag "Font Foundry" :help-echo "Font foundry name.")) + ;; The width, weight, and slant should be in sync with font.c. (:width (choice :tag "Width" :help-echo "Font width." @@ -63,15 +64,21 @@ (const :tag "demiexpanded" semi-expanded) (const :tag "expanded" expanded) (const :tag "extracondensed" extra-condensed) + (const :tag "extra-condensed" extra-condensed) (const :tag "extraexpanded" extra-expanded) - (const :tag "medium" normal) + (const :tag "extra-expanded" extra-expanded) (const :tag "narrow" condensed) (const :tag "normal" normal) + (const :tag "medium" normal) (const :tag "regular" normal) (const :tag "semicondensed" semi-condensed) + (const :tag "demicondensed" semi-condensed) + (const :tag "semi-condensed" semi-condensed) (const :tag "semiexpanded" semi-expanded) (const :tag "ultracondensed" ultra-condensed) + (const :tag "ultra-condensed" ultra-condensed) (const :tag "ultraexpanded" ultra-expanded) + (const :tag "ultra-expanded" ultra-expanded) (const :tag "wide" extra-expanded))) (:height @@ -85,22 +92,32 @@ (choice :tag "Weight" :help-echo "Font weight." :value normal ; default - (const :tag "ultralight" ultra-light) - (const :tag "extralight" extra-light) - (const :tag "light" light) (const :tag "thin" thin) + (const :tag "ultralight" ultra-light) + (const :tag "ultra-light" ultra-light) + (const :tag "extralight" ultra-light) + (const :tag "extra-light" ultra-light) + (const :tag "light" light) (const :tag "semilight" semi-light) - (const :tag "book" semi-light) + (const :tag "semi-light" semi-light) + (const :tag "demilight" semi-light) (const :tag "normal" normal) - (const :tag "regular" normal) - (const :tag "medium" normal) + (const :tag "regular" regular) + (const :tag "book" normal) + (const :tag "medium" medium) (const :tag "semibold" semi-bold) + (const :tag "semi-bold" semi-bold) (const :tag "demibold" semi-bold) + (const :tag "demi-bold" semi-bold) (const :tag "bold" bold) (const :tag "extrabold" extra-bold) - (const :tag "heavy" extra-bold) - (const :tag "ultrabold" ultra-bold) - (const :tag "black" ultra-bold))) + (const :tag "extra-bold" extra-bold) + (const :tag "ultrabold" extra-bold) + (const :tag "ultra-bold" extra-bold) + (const :tag "heavy" heavy) + (const :tag "black" heavy) + (const :tag "ultra-heavy" ultra-heavy) + (const :tag "ultraheavy" ultra-heavy))) (:slant (choice :tag "Slant" diff --git a/lisp/cus-start.el b/lisp/cus-start.el index a46107a6784..33b861b3408 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -826,10 +826,15 @@ since it could result in memory overflow and make Emacs crash." (x-underline-at-descent-line display boolean "22.1") (x-stretch-cursor display boolean "21.1") (scroll-bar-adjust-thumb-portion windows boolean "24.4") + (x-scroll-event-delta-factor mouse float "29.1") ;; xselect.c (x-select-enable-clipboard-manager killing boolean "24.1") ;; xsettings.c - (font-use-system-font font-selection boolean "23.2"))) + (font-use-system-font font-selection boolean "23.2") + ;; haikuterm.c + (haiku-debug-on-fatal-error debug boolean "29.1") + ;; haikufns.c + (haiku-use-system-tooltips tooltip boolean "29.1"))) (setq ;; If we did not specify any standard value expression above, ;; use the current value as the standard value. standard (if (setq prop (memq :standard rest)) @@ -846,10 +851,17 @@ since it could result in memory overflow and make Emacs crash." (eq system-type 'windows-nt)) ((string-match "\\`ns-" (symbol-name symbol)) (featurep 'ns)) + ((string-match "\\`haiku-" (symbol-name symbol)) + (featurep 'haiku)) ((string-match "\\`x-.*gtk" (symbol-name symbol)) (featurep 'gtk)) ((string-match "clipboard-manager" (symbol-name symbol)) (boundp 'x-select-enable-clipboard-manager)) + ((or (equal "scroll-bar-adjust-thumb-portion" + (symbol-name symbol)) + (equal "x-scroll-event-delta-factor" + (symbol-name symbol))) + (featurep 'x)) ((string-match "\\`x-" (symbol-name symbol)) (fboundp 'x-create-frame)) ((string-match "selection" (symbol-name symbol)) @@ -870,9 +882,6 @@ since it could result in memory overflow and make Emacs crash." (symbol-name symbol)) ;; Any function from fontset.c will do. (fboundp 'new-fontset)) - ((equal "scroll-bar-adjust-thumb-portion" - (symbol-name symbol)) - (featurep 'x)) (t t)))) (if (not (boundp symbol)) ;; If variables are removed from C code, give an error here! diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 7d81d45326f..588551a6417 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1007,6 +1007,7 @@ Else returns nil for success." (erase-buffer) (setq default-directory dir ; caller's default-directory err (not (eq 0 (apply #'process-file program nil t nil arguments)))) + (dired-uncache dir) (if err (progn (dired-log (concat program " " (prin1-to-string arguments) "\n")) @@ -1032,6 +1033,7 @@ Return the result of `process-file' - zero for success." nil shell-command-switch cmd))) + (dired-uncache dir) (unless (zerop res) (pop-to-buffer out-buffer)) res)))) @@ -1280,9 +1282,9 @@ Return nil if no change in files." (prog1 (setq newname (file-name-as-directory newname)) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument newname) + "%o" (shell-quote-argument (file-local-name newname)) (replace-regexp-in-string - "%i" (shell-quote-argument file) + "%i" (shell-quote-argument (file-local-name file)) command nil t) nil t))) @@ -1293,10 +1295,10 @@ Return nil if no change in files." (dired-check-process msg (substring command 0 match) (substring command (1+ match)) - file) + (file-local-name file)) (dired-check-process msg command - file)) + (file-local-name file))) newname)))) (t ;; We don't recognize the file as compressed, so compress it. @@ -1314,7 +1316,8 @@ Return nil if no change in files." (default-directory (file-name-directory file))) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument out-name) + "%o" (shell-quote-argument + (file-local-name out-name)) (replace-regexp-in-string "%i" (shell-quote-argument (file-name-nondirectory file)) @@ -1344,9 +1347,10 @@ see `dired-compress-file-alist' for the supported suffixes list" out-name))) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument out-name) + "%o" (shell-quote-argument + (file-local-name out-name)) (replace-regexp-in-string - "%i" (shell-quote-argument file) + "%i" (shell-quote-argument (file-local-name file)) (cdr rule) nil t) nil t)) @@ -1361,7 +1365,8 @@ see `dired-compress-file-alist' for the supported suffixes list" out-name))))) (file-error (if (not (dired-check-process (concat "Compressing " file) - "compress" "-f" file)) + "compress" "-f" + (file-local-name file))) ;; Don't use NEWNAME with `compress'. (concat file ".Z")))))))) @@ -1984,11 +1989,12 @@ or with the current marker character if MARKER-CHAR is t." (let* ((overwrite (file-exists-p to)) (dired-overwrite-confirmed ; for dired-handle-overwrite (and overwrite - (let ((help-form (format-message "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) + (let ((help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to overwrite file `%s', +\\`DEL' or \\`n' to skip to next, +\\`ESC' or \\`q' to not overwrite any of the remaining files, +\\`!' to overwrite all remaining files with no more questions.") to))) (dired-query 'overwrite-query "Overwrite `%s'?" to)))) ;; must determine if FROM is marked before file-creator @@ -2481,11 +2487,12 @@ Also see `dired-do-revert-buffer'." ;; Optional arg MARKER-CHAR as in dired-create-files. (let* ((fn-list (dired-get-marked-files nil arg)) (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format-message "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) + (rename-regexp-help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s one match, \\`DEL' or \\`n' to skip to next, +\\`!' to %s all remaining matches with no more questions.") + (downcase operation) + (downcase operation))) (regexp-name-constructor ;; Function to construct new filename using REGEXP and NEWNAME: (if whole-name ; easy (but rare) case @@ -2606,11 +2613,12 @@ See function `dired-do-rename-regexp' for more info." (let ((to (concat (file-name-directory from) (funcall basename-constructor (file-name-nondirectory from))))) - (and (let ((help-form (format-message "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) + (and (let ((help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s one file, \\`DEL' or \\`n' to skip to next, +\\`!' to %s all remaining matches with no more questions.") + (downcase operation) + (downcase operation)))) (dired-query 'rename-non-directory-query (concat operation " `%s' to `%s'") (dired-make-relative from) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index fc626aa76b5..de21dcf7a60 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -596,7 +596,7 @@ If you have saved a Dired buffer in a file you can use \\[dired-virtual] to resume it in a later session. Type \\\\[revert-buffer] \ -in the Virtual Dired buffer and answer `y' to convert +in the Virtual Dired buffer and answer \\`y' to convert the virtual to a real Dired buffer again. You don't have to do this, though: you can relist single subdirs using \\[dired-do-redisplay]." diff --git a/lisp/dired.el b/lisp/dired.el index 40dfc39b9ad..9280c080a4c 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -345,11 +345,11 @@ When `file', the region marking is based on the file name. This means don't mark the file if the end of the region is before the file name displayed on the Dired line, so the file name is visually outside the region. This behavior is consistent with -marking files without the region using the key `m' that advances +marking files without the region using the key \\`m' that advances point to the next line after marking the file. Thus the number of keys used to mark files is the same as the number of keys -used to select the region, e.g. `M-2 m' marks 2 files, and -`C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files. +used to select the region, for example \\`M-2 m' marks 2 files, and +\\`C-SPC M-2 n m' marks 2 files, and \\`M-2 S- m' marks 2 files. When `line', the region marking is based on Dired lines, so include the file into marking if the end of the region @@ -1672,9 +1672,9 @@ see `dired-use-ls-dired' for more details.") (dired-goto-subdir current-dir) (dired current-dir))))) (define-keymap - [mouse-2] click - [follow-link] 'mouse-face - ["RET"] click)))) + "" click + "" 'mouse-face + "RET" click)))) (setq segment-start (point))))))) @@ -2449,7 +2449,9 @@ directory in another window." file-name (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") - (error "File no longer exists; type `g' to update Dired buffer"))))) + (error (substitute-command-keys + (concat "File no longer exists; type \\" + "\\[revert-buffer] to update Dired buffer"))))))) ;; Force C-m keybinding rather than `f' or `e' in the mode doc: (define-obsolete-function-alias 'dired-advertised-find-file @@ -4100,9 +4102,9 @@ Type \\[help-command] at that time for help." (inhibit-read-only t) case-fold-search dired-unmark-all-files-query (string (format "\n%c" mark)) - (help-form "\ -Type SPC or `y' to unmark one file, DEL or `n' to skip to next, -`!' to unmark all remaining files with no more questions.")) + (help-form (substitute-command-keys "\ +Type \\`SPC' or \\`y' to unmark one file, \\`DEL' or \\`n' to skip to next, +\\`!' to unmark all remaining files with no more questions."))) (goto-char (point-min)) (while (if (eq mark ?\r) (re-search-forward dired-re-mark nil t) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 088ca5bfeae..7e113e4f34c 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -493,24 +493,69 @@ Typically \"page-%s.png\".") (easy-menu-define doc-view-menu doc-view-mode-map "Menu for Doc View mode." '("DocView" - ["Toggle display" doc-view-toggle-display] - ("Continuous" - ["Off" (setq doc-view-continuous nil) - :style radio :selected (eq doc-view-continuous nil)] - ["On" (setq doc-view-continuous t) - :style radio :selected (eq doc-view-continuous t)] + ["Next page" doc-view-next-page + :help "Go to the next page"] + ["Previous page" doc-view-previous-page + :help "Go to the previous page"] + ("Other Navigation" + ["Go to page..." doc-view-goto-page + :help "Go to specific page"] "---" - ["Save as Default" - (customize-save-variable 'doc-view-continuous doc-view-continuous) t] + ["First page" doc-view-first-page + :help "View the first page"] + ["Last page" doc-view-last-page + :help "View the last page"] + "---" + ["Move forward" doc-view-scroll-up-or-next-page + :help "Scroll page up or go to next page"] + ["Move backward" doc-view-scroll-down-or-previous-page + :help "Scroll page down or go to previous page"]) + ("Continuous Scrolling" + ["Off" (setq doc-view-continuous nil) + :style radio :selected (eq doc-view-continuous nil) + :help "Scrolling stops at page beginning and end"] + ["On" (setq doc-view-continuous t) + :style radio :selected (eq doc-view-continuous t) + :help "Scrolling continues to next or previous page"] + "---" + ["Save as Default" (customize-save-variable 'doc-view-continuous doc-view-continuous) + :help "Save current continuous scrolling option as default"] ) "---" - ["Set Slice" doc-view-set-slice-using-mouse] - ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box] - ["Set Slice (manual)" doc-view-set-slice] - ["Reset Slice" doc-view-reset-slice] + ("Toggle edit/display" + ["Edit document" doc-view-toggle-display + :style radio :selected (eq major-mode 'doc-view--text-view-mode)] + ["Display document" (lambda ()) ; ignore but show no keybinding + :style radio :selected (eq major-mode 'doc-view-mode)]) + ("Adjust Display" + ["Fit to window" doc-view-fit-page-to-window + :help "Fit the image to the window"] + ["Fit width" doc-view-fit-width-to-window + :help "Fit the image width to the window width"] + ["Fit height" doc-view-fit-height-to-window + :help "Fit the image height to the window height"] + "---" + ["Enlarge" doc-view-enlarge + :help "Enlarge the document"] + ["Shrink" doc-view-shrink + :help "Shrink the document"] + "---" + ["Set Slice" doc-view-set-slice-using-mouse + :help "Set the slice of the images that should be displayed"] + ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box + :help "Set the slice from the document's BoundingBox information"] + ["Set Slice (manual)" doc-view-set-slice + :help "Set the slice of the images that should be displayed"] + ["Reset Slice" doc-view-reset-slice + :help "Reset the current slice" + :enabled (image-mode-window-get 'slice)]) "---" - ["Search" doc-view-search] - ["Search Backwards" doc-view-search-backward] + ["New Search" (doc-view-search t) + :help "Initiate a new search"] + ["Search Forward" doc-view-search + :help "Jump to the next match or initiate a new search"] + ["Search Backward" doc-view-search-backward + :help "Jump to the previous match or initiate a new search"] )) (defvar doc-view-minor-mode-map @@ -520,6 +565,16 @@ Typically \"page-%s.png\".") map) "Keymap used by `doc-view-minor-mode'.") +(easy-menu-define doc-view-minor-mode-menu doc-view-minor-mode-map + "Menu for Doc View minor mode." + '("DocView (edit)" + ("Toggle edit/display" + ["Edit document" (lambda ()) ; ignore but show no keybinding + :style radio :selected (eq major-mode 'doc-view--text-view-mode)] + ["Display document" doc-view-toggle-display + :style radio :selected (eq major-mode 'doc-view-mode)]) + ["Exit DocView Mode" doc-view-minor-mode])) + ;;;; Navigation Commands ;; FIXME: The doc-view-current-* definitions below are macros because they @@ -1530,16 +1585,16 @@ have the page we want to view." (overlay-put (doc-view-current-overlay) 'display (concat (propertize "Welcome to DocView!" 'face 'bold) "\n" - " + (substitute-command-keys " If you see this buffer it means that the document you want to view is being converted to PNG and the conversion of the first page hasn't finished yet or `doc-view-conversion-refresh-interval' is set to nil. For now these keys are useful: - -`q' : Bury this buffer. Conversion will go on in background. -`k' : Kill the conversion process and this buffer. -`K' : Kill the conversion process.\n")))) +\\ +\\[quit-window] : Bury this buffer. Conversion will go on in background. +\\[image-kill-buffer] : Kill the conversion process and this buffer. +\\[doc-view-kill-proc] : Kill the conversion process.\n"))))) (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) diff --git a/lisp/edmacro.el b/lisp/edmacro.el index b3118b0aa67..29900a9595c 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -601,6 +601,12 @@ This function assumes that the events can be stored in a string." (setf (aref seq i) (logand (aref seq i) 127)))) seq) +;; These are needed in a --without-x build. +(defvar mouse-wheel-down-event) +(defvar mouse-wheel-up-event) +(defvar mouse-wheel-right-event) +(defvar mouse-wheel-left-event) + (defun edmacro-fix-menu-commands (macro &optional noerror) (if (vectorp macro) (let (result) diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index a5721aa3193..a8b484aee0b 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -55,9 +55,9 @@ order to debug the code that does fontification." (defcustom backtrace-line-length 5000 "Target length for lines in Backtrace buffers. Backtrace mode will attempt to abbreviate printing of backtrace -frames to make them shorter than this, but success is not -guaranteed. If set to nil or zero, Backtrace mode will not -abbreviate the forms it prints." +frames by setting `print-level' and `print-length' to make them +shorter than this, but success is not guaranteed. If set to nil +or zero, backtrace mode will not abbreviate the forms it prints." :type 'integer :group 'backtrace :version "27.1") @@ -751,6 +751,13 @@ property for use by navigation." (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) (put-text-property beg (point) 'backtrace-section 'func))) +(defun backtrace--line-length-or-nil () + "Return `backtrace-line-length' if valid, nil else." + ;; mirror the logic in `cl-print-to-string-with-limits' + (and (natnump backtrace-line-length) + (not (zerop backtrace-line-length)) + backtrace-line-length)) + (defun backtrace--print-func-and-args (frame _view) "Print the function, arguments and buffer position of a backtrace FRAME. Format it according to VIEW." @@ -769,11 +776,16 @@ Format it according to VIEW." (if (atom fun) (funcall backtrace-print-function fun) (insert - (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) + (backtrace--print-to-string + fun + (when (and args (backtrace--line-length-or-nil)) + (/ backtrace-line-length 2))))) (if args (insert (backtrace--print-to-string - args (max (truncate (/ backtrace-line-length 5)) - (- backtrace-line-length (- (point) beg))))) + args + (if (backtrace--line-length-or-nil) + (max (truncate (/ backtrace-line-length 5)) + (- backtrace-line-length (- (point) beg)))))) ;; The backtrace-form property is so that backtrace-multi-line ;; will find it. backtrace-multi-line doesn't do anything ;; useful with it, just being consistent. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 9c64083b64b..f6db803b78e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1186,72 +1186,6 @@ See Info node `(elisp) Integer Basics'." (put 'concat 'byte-optimizer #'byte-optimize-concat) -(defun byte-optimize-define-key (form) - "Expand key bindings in FORM." - (let ((key (nth 2 form))) - (if (and (vectorp key) - (= (length key) 1) - (stringp (aref key 0))) - ;; We have key on the form ["C-c C-c"]. - (if (not (kbd-valid-p (aref key 0))) - (error "Invalid `kbd' syntax: %S" key) - (list (nth 0 form) (nth 1 form) - (kbd (aref key 0)) (nth 4 form))) - ;; No improvement. - form))) - -(put 'define-key 'byte-optimizer #'byte-optimize-define-key) - -(defun byte-optimize-define-keymap (form) - "Expand key bindings in FORM." - (let ((result nil) - (orig-form form) - improved) - (push (pop form) result) - (while (and form - (keywordp (car form)) - (not (eq (car form) :menu))) - (unless (memq (car form) - '(:full :keymap :parent :suppress :name :prefix)) - (error "Invalid keyword: %s" (car form))) - (push (pop form) result) - (when (null form) - (error "Uneven number of keywords in %S" form)) - (push (pop form) result)) - ;; Bindings. - (while form - (let ((key (pop form))) - (if (and (vectorp key) - (= (length key) 1) - (stringp (aref key 0))) - (progn - (unless (kbd-valid-p (aref key 0)) - (error "Invalid `kbd' syntax: %S" key)) - (push (kbd (aref key 0)) result) - (setq improved t)) - ;; No improvement. - (push key result))) - (when (null form) - (error "Uneven number of key bindings in %S" form)) - (push (pop form) result)) - (if improved - (nreverse result) - orig-form))) - -(defun byte-optimize-define-keymap--define (form) - "Expand key bindings in FORM." - (if (not (consp (nth 1 form))) - form - (let ((optimized (byte-optimize-define-keymap (nth 1 form)))) - (if (eq optimized (nth 1 form)) - ;; No improvement. - form - (list (car form) optimized))))) - -(put 'define-keymap 'byte-optimizer #'byte-optimize-define-keymap) -(put 'define-keymap--define 'byte-optimizer - #'byte-optimize-define-keymap--define) - ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index d82d9454e84..2ce2efd2aa7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -134,6 +134,7 @@ The return value of this function is not used." :autoload-end (eval-and-compile (defun ,cfname (,@(car data) ,@args) + (ignore ,@(delq '&rest (delq '&optional (copy-sequence args)))) ,@(cdr data)))))))) (defalias 'byte-run--set-doc-string diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 471a0b623ad..5ce5b2952b8 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1672,9 +1672,14 @@ URLs." ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. (replace-regexp-in-string - (rx "\\" (or (seq "[" (* (not "]")) "]"))) + (rx "\\[" (* (not "]")) "]") (make-string byte-compile--wide-docstring-substitution-len ?x) - docstring)))) + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (replace-regexp-in-string + (rx "\\`" (group (* (not "'"))) "'") + "\\1" + docstring))))) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. @@ -5043,6 +5048,8 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + ;;; tags diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index b30d3fc30f4..cd0e7dca7cf 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -385,7 +385,8 @@ Also store it in `eldoc-last-message' and return that value." ;; The following configuration shows "Matches..." in the ;; echo area when point is after a closing bracket, which ;; conflicts with eldoc. - (and show-paren-context-when-offscreen + (and (boundp 'show-paren-context-when-offscreen) + show-paren-context-when-offscreen (not (pos-visible-in-window-p (overlay-end show-paren--overlay))))))) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 8ebc81fd418..946193e40dc 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -77,6 +77,35 @@ Use nil for no limit (caution: backtrace lines can be very long)." :type '(choice (const :tag "No truncation" nil) integer)) +(defvar ert-batch-print-length 10 + "`print-length' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-length' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-print-level 5 + "`print-level' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-level' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-backtrace-line-length t + "Target length for lines in ERT batch backtraces. + +Even modest settings for `print-length' and `print-level' can +produce extremely long lines in backtraces and lengthy delays in +forming them. This variable governs the target maximum line +length by manipulating these two variables while printing stack +traces. Setting this variable to t will re-use the value of +`backtrace-line-length' while printing stack traces in ERT batch +mode. Any other value will be temporarily bound to +`backtrace-line-length' when producing stack traces in batch +mode.") + (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) @@ -120,6 +149,10 @@ Use nil for no limit (caution: backtrace lines can be very long)." ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) + (when (and noninteractive (get symbol 'ert--test)) + ;; Make sure duplicated tests are discovered since the older test would + ;; be ignored silently otherwise. + (error "Test `%s' redefined" symbol)) (define-symbol-prop symbol 'ert--test definition) definition) @@ -175,6 +208,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" (declare (debug (&define [&name "test@" symbolp] @@ -1402,8 +1438,7 @@ Returns the stats object." (ert-reason-for-test-result result) "")))) (message "%s" ""))))) - (test-started - ) + (test-started) (test-ended (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) @@ -1413,8 +1448,14 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (insert (backtrace-to-string - (ert-test-result-with-condition-backtrace result))) + (let ((backtrace-line-length + (if (eq ert-batch-backtrace-line-length t) + backtrace-line-length + ert-batch-backtrace-line-length)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (insert (backtrace-to-string + (ert-test-result-with-condition-backtrace result)))) (if (not ert-batch-backtrace-right-margin) (message "%s" (buffer-substring-no-properties (point-min) @@ -1433,8 +1474,8 @@ Returns the stats object." (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) - (print-level 5) - (print-length 10)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) @@ -1962,13 +2003,13 @@ otherwise." (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) -(defun ert--setup-results-buffer (stats listener buffer-name) +(defvar ert--output-buffer-name "*ert*") + +(defun ert--setup-results-buffer (stats listener) "Set up a test results buffer. -STATS is the stats object; LISTENER is the results listener; -BUFFER-NAME, if non-nil, is the buffer name to use." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (get-buffer-create buffer-name))) +STATS is the stats object; LISTENER is the results listener." + (let ((buffer (get-buffer-create ert--output-buffer-name))) (with-current-buffer buffer (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2000,18 +2041,11 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (defvar ert--selector-history nil "List of recent test selectors read from terminal.") -;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? -;; They are needed only for our automated self-tests at the moment. -;; Or should there be some other mechanism? ;;;###autoload -(defun ert-run-tests-interactively (selector - &optional output-buffer-name message-fn) +(defun ert-run-tests-interactively (selector) "Run the tests specified by SELECTOR and display the results in a buffer. -SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message." +SELECTOR works as described in `ert-select-tests'." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is @@ -2022,25 +2056,18 @@ and how to display message." (read (completing-read (format-prompt "Run tests" default) obarray #'ert-test-boundp nil nil - 'ert--selector-history default nil))) - nil)) - (unless message-fn (setq message-fn 'message)) - (let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + 'ert--selector-history default nil))))) + (let (buffer listener) (setq listener (lambda (event-type &rest event-args) (cl-ecase event-type (run-started (cl-destructuring-bind (stats) event-args - (setq buffer (ert--setup-results-buffer stats - listener - output-buffer-name)) + (setq buffer (ert--setup-results-buffer stats listener)) (pop-to-buffer buffer))) (run-ended (cl-destructuring-bind (stats abortedp) event-args - (funcall message-fn + (message "%sRan %s tests, %s results were as expected%s%s" (if (not abortedp) "" @@ -2394,7 +2421,7 @@ To be used in the ERT results buffer." (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) - (ert-run-tests-interactively selector (buffer-name)))) + (ert-run-tests-interactively selector))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index d90d0f5f6ac..416d64558d9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1308,6 +1308,7 @@ Lisp function does not specify a special indentation." (put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer '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/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b95f11eab64..2f2f96ca0da 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -215,12 +215,12 @@ The function's value is the number of actions taken." (action (or (nth 2 help) "act on"))) (concat (format-message - "\ -Type SPC or `y' to %s the current %s; -DEL or `n' to skip the current %s; -RET or `q' to skip the current and all remaining %s; -C-g to quit (cancel the whole command); -! to %s all remaining %s;\n" + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s the current %s; +\\`DEL' or \\`n' to skip the current %s; +\\`RET' or \\`q' to skip the current and all remaining %s; +\\`C-g' to quit (cancel the whole command); +\\`!' to %s all remaining %s;\n") action object object objects action objects) (mapconcat (lambda (elt) (format "%s to %s;\n" diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index aec438ed994..5516b2a81f4 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -448,7 +448,8 @@ provided in the Commentary section of this library." (setq reb-subexp-mode t) (reb-update-modestring) (use-local-map reb-subexp-mode-map) - (message "`0'-`9' to display subexpressions `q' to quit subexp mode")) + (message (substitute-command-keys + "\\`0'-\\`9' to display subexpressions \\`q' to quit subexp mode"))) (defun reb-show-subexp (subexp &optional pause) "Visually show limit of subexpression SUBEXP of recent search. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index a9f548b104e..ba08e68af57 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -159,8 +159,6 @@ There can be any number of :example/:result elements." :eval (split-string-and-unquote "foo \"bar zot\"")) (split-string-shell-command :eval (split-string-shell-command "ls /tmp/'foo bar'")) - (string-glyph-split - :eval (string-glyph-split "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻")) (string-lines :eval (string-lines "foo\n\nbar") :eval (string-lines "foo\n\nbar" t)) @@ -198,6 +196,13 @@ There can be any number of :example/:result elements." :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) (try-completion :eval (try-completion "foo" '("foobar" "foozot" "gazonk"))) + "Unicode Strings" + (string-glyph-split + :eval (string-glyph-split "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻")) + (string-glyph-compose + :eval (string-glyph-compose "Å")) + (string-glyph-decompose + :eval (string-glyph-decompose "Å")) "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) @@ -1222,6 +1227,39 @@ There can be any number of :example/:result elements." (text-property-search-backward :no-eval (text-property-search-backward 'face nil t))) +(define-short-documentation-group keymaps + "Defining keymaps" + (define-keymap + :no-eval (define-keymap "C-c C-c" #'quit-buffer)) + (defvar-keymap + :no-eval (defvar-keymap my-keymap "C-c C-c" map #'quit-buffer)) + "Setting keys" + (keymap-set + :no-eval (keymap-set map "C-c C-c" #'quit-buffer)) + (keymap-local-set + :no-eval (keymap-local-set "C-c C-c" #'quit-buffer)) + (keymap-global-set + :no-eval (keymap-global-set "C-c C-c" #'quit-buffer)) + (keymap-unset + :no-eval (keymap-unset map "C-c C-c")) + (keymap-local-unset + :no-eval (keymap-local-unset "C-c C-c")) + (keymap-global-unset + :no-eval (keymap-global-unset "C-c C-c")) + (keymap-substitute + :no-eval (keymap-substitute map "C-c C-c" "M-a")) + (keymap-set-after + :no-eval (keymap-set-after map "" menu-bar-separator)) + "Predicates" + (keymapp + :eval (keymapp (define-keymap))) + (key-valid-p + :eval (key-valid-p "C-c C-c") + :eval (key-valid-p "C-cC-c")) + "Lookup" + (keymap-lookup + :eval (keymap-lookup (current-global-map) "C-x x g"))) + ;;;###autoload (defun shortdoc-display-group (group &optional function) "Pop to a buffer with short documentation summary for functions in GROUP. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index f336799040f..b53245b9b5f 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -446,8 +446,7 @@ is inserted before adjusting the number of empty lines." "Return the width of STRING in pixels." (with-temp-buffer (insert string) - (car (window-text-pixel-size - (current-buffer) (point-min) (point))))) + (car (buffer-text-pixel-size nil nil t)))) ;;;###autoload (defun string-glyph-split (string) @@ -457,7 +456,12 @@ This takes into account combining characters and grapheme clusters." (start 0) comp) (while (< start (length string)) - (if (setq comp (find-composition-internal start nil string nil)) + (if (setq comp (find-composition-internal + start + ;; Don't search backward in the string for the + ;; start of the composition. + (min (length string) (1+ start)) + string nil)) (progn (push (substring string (car comp) (cadr comp)) result) (setq start (cadr comp))) @@ -465,6 +469,48 @@ This takes into account combining characters and grapheme clusters." (setq start (1+ start)))) (nreverse result))) +;;;###autoload +(defun add-display-text-property (start end prop value + &optional object) + "Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer." + (let ((sub-start start) + (sub-end 0) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + (if (stringp object) + (min (length object) end) + (min end (point-max))))) + (if (not (setq disp (get-text-property sub-start 'display object))) + ;; No old properties in this range. + (put-text-property sub-start sub-end 'display (list prop value)) + ;; We have old properties. + (let ((vector nil)) + ;; Make disp into a list. + (setq disp + (cond + ((vectorp disp) + (setq vector t) + (seq-into disp 'list)) + ((not (consp (car disp))) + (list disp)) + (t + disp))) + ;; Remove any old instances. + (when-let ((old (assoc prop disp))) + (setq disp (delete old disp))) + (setq disp (cons (list prop value) disp)) + (when vector + (setq disp (seq-into disp 'vector))) + ;; Finally update the range. + (put-text-property sub-start sub-end 'display disp))) + (setq sub-start sub-end)))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 59be3f48462..849ad3d8241 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -2311,7 +2311,6 @@ problems." (viper-downgrade-to-insert)) (defun viper-start-R-mode () - ;; Leave arg as 1, not t: XEmacs insists that it must be a pos number (overwrite-mode 1) (add-hook 'viper-post-command-hooks #'viper-R-state-post-command-sentinel t 'local) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index e3790b74534..368a5dc40a6 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -44,7 +44,6 @@ (define-obsolete-function-alias 'viper-device-type #'window-system "27.1") -;; in XEmacs: device-type is tty on tty and stream in batch. (defun viper-window-display-p () (and window-system (not (memq window-system '(tty stream pc))))) diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 3d55690bd6f..879d8edca6f 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -198,8 +198,7 @@ is ignored." (setq result (buffer-substring word-beg (point)))) ) ; if - ;; XEmacs doesn't have set-text-properties, but there buffer-substring - ;; doesn't return properties together with the string, so it's not needed. + ;; FIXME: Use `buffer-substring-no-properties' above instead? (set-text-properties 0 (length result) nil result) result)) diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index 35caa1a93c5..5dd6ad34d74 100644 --- a/lisp/epa-ks.el +++ b/lisp/epa-ks.el @@ -210,7 +210,8 @@ KEYS is a list of `epa-ks-key' structures, as parsed by (with-current-buffer buf (setq tabulated-list-entries entries) (tabulated-list-print t t)) - (message "Press `f' to mark a key, `x' to fetch all marked keys.")))) + (message (substitute-command-keys + "Press \\`f' to mark a key, \\`x' to fetch all marked keys."))))) (defun epa-ks--restart-search () (when epa-ks-last-query diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index abb1f64a822..df6c3c09d90 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1479,6 +1479,7 @@ Defaults to the server buffer." (define-derived-mode erc-mode fundamental-mode "ERC" "Major mode for Emacs IRC." + :interactive nil (setq local-abbrev-table erc-mode-abbrev-table) (setq-local next-line-add-newlines nil) (setq line-move-ignore-invisible t) @@ -2404,7 +2405,8 @@ If ARG is non-nil, show the *erc-protocol* buffer." (concat "This buffer displays all IRC protocol " "traffic exchanged with servers.")) (erc-make-notice "Kill it to disable logging.") - (erc-make-notice "Press `t' to toggle.")))) + (erc-make-notice (substitute-command-keys + "Press \\`t' to toggle."))))) (insert (string-join msg "\r\n"))) (use-local-map (make-sparse-keymap)) (local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol)) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index a054cd66e27..cae5236d894 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -308,7 +308,7 @@ and the hook `eshell-exit-hook'." (make-local-variable 'eshell-command-running-string) (let ((fmt (copy-sequence mode-line-format))) (setq-local mode-line-format fmt)) - (let ((mode-line-elt (memq 'mode-line-modified mode-line-format))) + (let ((mode-line-elt (cdr (memq 'mode-line-front-space mode-line-format)))) (if mode-line-elt (setcar mode-line-elt 'eshell-command-running-string)))) diff --git a/lisp/faces.el b/lisp/faces.el index 5804f56378f..535fa44246e 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1172,9 +1172,8 @@ an integer value." (:height 'integerp) (:stipple - (and (memq (window-system frame) '(x ns pgtk)) ; No stipple on w32 - (mapcar (lambda (f) - (cons (file-name-base f) f)) + (and (memq (window-system frame) '(x ns pgtk)) ; No stipple on w32 or haiku + (mapcar #'list (apply #'nconc (mapcar (lambda (dir) (and (file-readable-p dir) @@ -2615,14 +2614,23 @@ non-nil." :background "grey75" :foreground "black") (t :inverse-video t)) - "Basic mode line face for selected window." + "Face for the mode lines (for the selected window) as well as header lines. +See `mode-line-display' for the face used on mode lines." :version "21.1" :group 'mode-line-faces :group 'basic-faces) +(defface mode-line-active + '((t :inherit (mode-line variable-pitch))) + "Face for the selected mode line. +This inherits from the `mode-line' face." + :version "29.1" + :group 'mode-line-faces + :group 'basic-faces) + (defface mode-line-inactive '((default - :inherit mode-line) + :inherit (mode-line variable-pitch)) (((class color) (min-colors 88) (background light)) :weight light :box (:line-width -1 :color "grey75" :style nil) @@ -2823,7 +2831,7 @@ Note: Other faces cannot inherit from the cursor face." '((default :box (:line-width 1 :style released-button) :foreground "black") - (((type x w32 ns pgtk) (class color)) + (((type x w32 ns haiku pgtk) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) @@ -2884,13 +2892,17 @@ Note: Other faces cannot inherit from the cursor face." ;; making the characters wider, which then would cause unpleasant ;; horizontal shifts of the cursor during C-n/C-p movement ;; through a line with this face. - :box (:line-width (-1 . -1) :color "grey80")) + :box (:line-width (-1 . -1) :color "grey80") + :inherit fixed-pitch) (((class color) (min-colors 88) (background dark)) :background "grey19" :foreground "LightBlue" - :box (:line-width (-1 . -1) :color "grey35")) - (((class color grayscale) (background light)) :background "grey90") - (((class color grayscale) (background dark)) :background "grey25") - (t :background "grey90")) + :box (:line-width (-1 . -1) :color "grey35") + :inherit fixed-pitch) + (((class color grayscale) (background light)) :background "grey90" + :inherit fixed-pitch) + (((class color grayscale) (background dark)) :background "grey25" + :inherit fixed-pitch) + (t :background "grey90" :inherit fixed-pitch)) "Face for keybindings in *Help* buffers. This face is added by `substitute-command-keys', which see. diff --git a/lisp/files.el b/lisp/files.el index 3490d0428a0..f72723ab7dd 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -68,6 +68,31 @@ a regexp matching the name it is linked to." :group 'abbrev :group 'find-file) +(defun directory-abbrev-make-regexp (directory) + "Create a regexp to match DIRECTORY for `directory-abbrev-alist'." + (let ((regexp + ;; We include a slash at the end, to avoid spurious + ;; matches such as `/usr/foobar' when the home dir is + ;; `/usr/foo'. + (concat "\\`" (regexp-quote directory) "\\(/\\|\\'\\)"))) + ;; The value of regexp could be multibyte or unibyte. In the + ;; latter case, we need to decode it. + (if (multibyte-string-p regexp) + regexp + (decode-coding-string regexp + (if (eq system-type 'windows-nt) + 'utf-8 + locale-coding-system))))) + +(defun directory-abbrev-apply (filename) + "Apply the abbreviations in `directory-abbrev-alist' to FILENAME. +Note that when calling this, you should set `case-fold-search' as +appropriate for the filesystem used for FILENAME." + (dolist (dir-abbrev directory-abbrev-alist filename) + (when (string-match (car dir-abbrev) filename) + (setq filename (concat (cdr dir-abbrev) + (substring filename (match-end 0))))))) + (defcustom make-backup-files t "Non-nil means make a backup of a file the first time it is saved. This can be done by renaming the file or by copying. @@ -2015,73 +2040,54 @@ if you want to permanently change your home directory after having started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; Get rid of the prefixes added by the automounter. (save-match-data ;FIXME: Why? - (if (and automount-dir-prefix - (string-match automount-dir-prefix filename) - (file-exists-p (file-name-directory - (substring filename (1- (match-end 0)))))) - (setq filename (substring filename (1- (match-end 0))))) - ;; Avoid treating /home/foo as /home/Foo during `~' substitution. - (let ((case-fold-search (file-name-case-insensitive-p filename))) - ;; If any elt of directory-abbrev-alist matches this name, - ;; abbreviate accordingly. - (dolist (dir-abbrev directory-abbrev-alist) - (if (string-match (car dir-abbrev) filename) - (setq filename - (concat (cdr dir-abbrev) - (substring filename (match-end 0)))))) - ;; Compute and save the abbreviated homedir name. - ;; We defer computing this until the first time it's needed, to - ;; give time for directory-abbrev-alist to be set properly. - ;; We include a slash at the end, to avoid spurious matches - ;; such as `/usr/foobar' when the home dir is `/usr/foo'. - (unless abbreviated-home-dir - (put 'abbreviated-home-dir 'home (expand-file-name "~")) - (setq abbreviated-home-dir - (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. - (regexp - (concat "\\`" - (regexp-quote - (abbreviate-file-name - (get 'abbreviated-home-dir 'home))) - "\\(/\\|\\'\\)"))) - ;; Depending on whether default-directory does or - ;; doesn't include non-ASCII characters, the value - ;; of abbreviated-home-dir could be multibyte or - ;; unibyte. In the latter case, we need to decode - ;; it. Note that this function is called for the - ;; first time (from startup.el) when - ;; locale-coding-system is already set up. - (if (multibyte-string-p regexp) - regexp - (decode-coding-string regexp - (if (eq system-type 'windows-nt) - 'utf-8 - locale-coding-system)))))) + (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (funcall handler 'abbreviate-file-name filename) + (if (and automount-dir-prefix + (string-match automount-dir-prefix filename) + (file-exists-p (file-name-directory + (substring filename (1- (match-end 0)))))) + (setq filename (substring filename (1- (match-end 0))))) + ;; Avoid treating /home/foo as /home/Foo during `~' substitution. + (let ((case-fold-search (file-name-case-insensitive-p filename))) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (setq filename (directory-abbrev-apply filename)) - ;; If FILENAME starts with the abbreviated homedir, - ;; and ~ hasn't changed since abbreviated-home-dir was set, - ;; make it start with `~' instead. - ;; If ~ has changed, we ignore abbreviated-home-dir rather than - ;; invalidating it, on the assumption that a change in HOME - ;; is likely temporary (eg for testing). - ;; FIXME Is it even worth caching abbreviated-home-dir? - ;; Ref: https://debbugs.gnu.org/19657#20 - (let (mb1) - (if (and (string-match abbreviated-home-dir filename) - (setq mb1 (match-beginning 1)) - ;; If the home dir is just /, don't change it. - (not (and (= (match-end 0) 1) - (= (aref filename 0) ?/))) - ;; MS-DOS root directories can come with a drive letter; - ;; Novell Netware allows drive letters beyond `Z:'. - (not (and (memq system-type '(ms-dos windows-nt cygwin)) - (string-match "\\`[a-zA-`]:/\\'" filename))) - (equal (get 'abbreviated-home-dir 'home) - (expand-file-name "~"))) - (setq filename - (concat "~" - (substring filename mb1)))) - filename)))) + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + (unless abbreviated-home-dir + (put 'abbreviated-home-dir 'home (expand-file-name "~")) + (setq abbreviated-home-dir + (directory-abbrev-make-regexp + (let ((abbreviated-home-dir "\\`\\'.")) ;Impossible regexp. + (abbreviate-file-name + (get 'abbreviated-home-dir 'home)))))) + + ;; If FILENAME starts with the abbreviated homedir, + ;; and ~ hasn't changed since abbreviated-home-dir was set, + ;; make it start with `~' instead. + ;; If ~ has changed, we ignore abbreviated-home-dir rather than + ;; invalidating it, on the assumption that a change in HOME + ;; is likely temporary (eg for testing). + ;; FIXME Is it even worth caching abbreviated-home-dir? + ;; Ref: https://debbugs.gnu.org/19657#20 + (let (mb1) + (if (and (string-match abbreviated-home-dir filename) + (setq mb1 (match-beginning 1)) + ;; If the home dir is just /, don't change it. + (not (and (= (match-end 0) 1) + (= (aref filename 0) ?/))) + ;; MS-DOS root directories can come with a drive letter; + ;; Novell Netware allows drive letters beyond `Z:'. + (not (and (memq system-type '(ms-dos windows-nt cygwin)) + (string-match "\\`[a-zA-`]:/\\'" filename))) + (equal (get 'abbreviated-home-dir 'home) + (expand-file-name "~"))) + (setq filename + (concat "~" + (substring filename mb1)))) + filename))))) (defun find-buffer-visiting (filename &optional predicate) "Return the buffer visiting file FILENAME (a string). @@ -5800,13 +5806,13 @@ of the directory that was default during command invocation." (defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. -You can answer `y' or SPC to save, `n' or DEL not to save, `C-r' +You can answer \\`y' or \\`SPC' to save, \\`n' or \\`DEL' not to save, \\`C-r' to look at the buffer in question with `view-buffer' before -deciding, `d' to view the differences using -`diff-buffer-with-file', `!' to save the buffer and all remaining -buffers without any further querying, `.' to save only the -current buffer and skip the remaining ones and `q' or RET to exit -the function without saving any more buffers. `C-h' displays a +deciding, \\`d' to view the differences using +`diff-buffer-with-file', \\`!' to save the buffer and all remaining +buffers without any further querying, \\`.' to save only the +current buffer and skip the remaining ones and \\`q' or \\`RET' to exit +the function without saving any more buffers. \\`C-h' displays a help message describing these options. This command first saves any buffers where `buffer-save-without-query' is @@ -6218,8 +6224,7 @@ of `file-has-changed-p' always returns non-nil when FILE exists. The optional argument TAG, which must be a symbol, can be used to limit the comparison to invocations with identical tags; it can be the symbol of the calling function, for example." - (let* (;; FIXME: Shall we use `file-truename'? - (file (directory-file-name file)) + (let* ((file (directory-file-name (expand-file-name file))) (remote-file-name-inhibit-cache t) (fileattr (file-attributes file 'integer)) (attr (and fileattr @@ -7836,10 +7841,11 @@ only these files will be asked to be saved." ;; Get a list of the indices of the args that are file names. (file-arg-indices (cdr (or (assq operation - '(;; The first seven are special because they + '(;; The first eight are special because they ;; return a file name. We want to include ;; the /: in the return value. So just ;; avoid stripping it in the first place. + (abbreviate-file-name) (directory-file-name) (expand-file-name) (file-name-as-directory) diff --git a/lisp/follow.el b/lisp/follow.el index 2ca2c1f17ba..3761275bbf6 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -669,24 +669,30 @@ Works like `scroll-down' when not in Follow mode." (t (let* ((orig-point (point)) (windows (follow-all-followers)) - (win (car (reverse windows))) - (start (window-start (car windows)))) + (start (window-start (car windows))) + (lines 0)) (if (eq start (point-min)) (if (or (null scroll-error-top-bottom) (bobp)) (signal 'beginning-of-buffer nil) (goto-char (point-min))) - (select-window win) - (goto-char start) - (vertical-motion (- (- (window-height win) - (if header-line-format 2 1) ; always mode-line - (if tab-line-format 1 0) - next-screen-context-lines))) - (set-window-start win (point)) - (if (< orig-point (window-end win t)) - (goto-char orig-point) - (goto-char start) - (vertical-motion (- next-screen-context-lines 1))) + (select-window (car windows)) + (dolist (win windows) + (setq lines + (+ lines + (- (window-height win) + (if header-line-format 2 1) ; Count mode-line, too. + (if tab-line-format 1 0))))) + (setq lines (- lines next-screen-context-lines)) + (goto-char start) + (let ((at-top (> (vertical-motion (- lines)) (- lines)))) + (set-window-start (car windows) (point)) + (if at-top + (goto-char orig-point) + (goto-char start) + (vertical-motion (- next-screen-context-lines 1)) + (if (< orig-point (point)) + (goto-char orig-point)))) (setq follow-internal-force-redisplay t)))))) (put 'follow-scroll-down 'scroll-command t) diff --git a/lisp/frame.el b/lisp/frame.el index 5e54d8d9af7..c9306ec46df 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1634,6 +1634,7 @@ live frame and defaults to the selected one." (declare-function w32-frame-geometry "w32fns.c" (&optional frame)) (declare-function ns-frame-geometry "nsfns.m" (&optional frame)) (declare-function pgtk-frame-geometry "pgtkfns.c" (&optional frame)) +(declare-function haiku-frame-geometry "haikufns.c" (&optional frame)) (defun frame-geometry (&optional frame) "Return geometric attributes of FRAME. @@ -1685,6 +1686,8 @@ and width values are in pixels. (ns-frame-geometry frame)) ((eq frame-type 'pgtk) (pgtk-frame-geometry frame)) + ((eq frame-type 'haiku) + (haiku-frame-geometry frame)) (t (list '(outer-position 0 . 0) @@ -1810,6 +1813,7 @@ of frames like calls to map a frame or change its visibility." (declare-function w32-frame-edges "w32fns.c" (&optional frame type)) (declare-function ns-frame-edges "nsfns.m" (&optional frame type)) (declare-function pgtk-frame-edges "pgtkfns.c" (&optional frame type)) +(declare-function haiku-frame-edges "haikufns.c" (&optional frame type)) (defun frame-edges (&optional frame type) "Return coordinates of FRAME's edges. @@ -1835,6 +1839,8 @@ FRAME." (ns-frame-edges frame type)) ((eq frame-type 'pgtk) (pgtk-frame-edges frame type)) + ((eq frame-type 'haiku) + (haiku-frame-edges frame type)) (t (list 0 0 (frame-width frame) (frame-height frame)))))) @@ -1842,6 +1848,7 @@ FRAME." (declare-function x-mouse-absolute-pixel-position "xfns.c") (declare-function ns-mouse-absolute-pixel-position "nsfns.m") (declare-function pgtk-mouse-absolute-pixel-position "pgtkfns.c") +(declare-function haiku-mouse-absolute-pixel-position "haikufns.c") (defun mouse-absolute-pixel-position () "Return absolute position of mouse cursor in pixels. @@ -1858,6 +1865,8 @@ position (0, 0) of the selected frame's terminal." (ns-mouse-absolute-pixel-position)) ((eq frame-type 'pgtk) (pgtk-mouse-absolute-pixel-position)) + ((eq frame-type 'haiku) + (haiku-mouse-absolute-pixel-position)) (t (cons 0 0))))) @@ -1865,6 +1874,7 @@ position (0, 0) of the selected frame's terminal." (declare-function ns-set-mouse-absolute-pixel-position "nsfns.m" (x y)) (declare-function w32-set-mouse-absolute-pixel-position "w32fns.c" (x y)) (declare-function x-set-mouse-absolute-pixel-position "xfns.c" (x y)) +(declare-function haiku-set-mouse-absolute-pixel-position "haikufns.c" (x y)) (defun set-mouse-absolute-pixel-position (x y) "Move mouse pointer to absolute pixel position (X, Y). @@ -1879,7 +1889,9 @@ position (0, 0) of the selected frame's terminal." ((eq frame-type 'x) (x-set-mouse-absolute-pixel-position x y)) ((eq frame-type 'w32) - (w32-set-mouse-absolute-pixel-position x y))))) + (w32-set-mouse-absolute-pixel-position x y)) + ((eq frame-type 'haiku) + (haiku-set-mouse-absolute-pixel-position x y))))) (defun frame-monitor-attributes (&optional frame) "Return the attributes of the physical monitor dominating FRAME. @@ -1973,6 +1985,7 @@ workarea attribute." (declare-function w32-frame-list-z-order "w32fns.c" (&optional display)) (declare-function ns-frame-list-z-order "nsfns.m" (&optional display)) (declare-function pgtk-frame-list-z-order "pgtkfns.c" (&optional display)) +(declare-function haiku-frame-list-z-order "haikufns.c" (&optional display)) (defun frame-list-z-order (&optional display) "Return list of Emacs' frames, in Z (stacking) order. @@ -1994,7 +2007,9 @@ Return nil if DISPLAY contains no Emacs frame." ((eq frame-type 'ns) (ns-frame-list-z-order display)) ((eq frame-type 'pgtk) - (pgtk-frame-list-z-order display))))) + (pgtk-frame-list-z-order display)) + ((eq frame-type 'haiku) + (haiku-frame-list-z-order display))))) (declare-function x-frame-restack "xfns.c" (frame1 frame2 &optional above)) (declare-function w32-frame-restack "w32fns.c" (frame1 frame2 &optional above)) @@ -2078,8 +2093,8 @@ frame's display)." ((eq frame-type 'w32) (with-no-warnings (> w32-num-mouse-buttons 0))) - ((memq frame-type '(x ns pgtk)) - t) ;; We assume X and NeXTstep *always* have a pointing device + ((memq frame-type '(x ns haiku pgtk)) + t) ;; We assume X, NeXTstep, GTK, and Haiku *always* have a pointing device (t (or (and (featurep 'xt-mouse) xterm-mouse-mode) @@ -2104,7 +2119,7 @@ frames and several different fonts at once. This is true for displays that use a window system such as X, and false for text-only terminals. DISPLAY can be a display name, a frame, or nil (meaning the selected frame's display)." - (not (null (memq (framep-on-display display) '(x w32 ns pgtk))))) + (not (null (memq (framep-on-display display) '(x w32 ns haiku haiku))))) (defun display-images-p (&optional display) "Return non-nil if DISPLAY can display images. @@ -2155,7 +2170,7 @@ DISPLAY should be either a frame or a display name (a string). If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-screens display)) (t 1)))) @@ -2175,7 +2190,7 @@ with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-pixel-height display)) (t (frame-height (if (framep display) display (selected-frame))))))) @@ -2195,7 +2210,7 @@ with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-pixel-width display)) (t (frame-width (if (framep display) display (selected-frame))))))) @@ -2233,7 +2248,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this refers to the height in millimeters for all physical monitors associated with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." - (and (memq (framep-on-display display) '(x w32 ns pgtk)) + (and (memq (framep-on-display display) '(x w32 ns haiku pgtk)) (or (cddr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cddr (assoc t display-mm-dimensions-alist)) @@ -2254,7 +2269,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this refers to the width in millimeters for all physical monitors associated with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." - (and (memq (framep-on-display display) '(x w32 ns pgtk)) + (and (memq (framep-on-display display) '(x w32 ns haiku pgtk)) (or (cadr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cadr (assoc t display-mm-dimensions-alist)) @@ -2272,7 +2287,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-backing-store display)) (t 'not-useful)))) @@ -2285,7 +2300,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-save-under display)) (t 'not-useful)))) @@ -2298,7 +2313,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-planes display)) ((eq frame-type 'pc) 4) @@ -2313,7 +2328,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-color-cells display)) ((eq frame-type 'pc) 16) @@ -2330,7 +2345,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns pgtk)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-visual-class display)) ((and (memq frame-type '(pc t)) (tty-display-color-p display)) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 20da295aca9..169a351c2c7 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -476,15 +476,15 @@ manipulated as follows: (intern (format "gnus-agent-%s-mode-hook" buffer))))) (defvar-keymap gnus-agent-group-mode-map - "Ju" #'gnus-agent-fetch-groups - "Jc" #'gnus-enter-category-buffer - "Jj" #'gnus-agent-toggle-plugged - "Js" #'gnus-agent-fetch-session - "JY" #'gnus-agent-synchronize-flags - "JS" #'gnus-group-send-queue - "Ja" #'gnus-agent-add-group - "Jr" #'gnus-agent-remove-group - "Jo" #'gnus-agent-toggle-group-plugged) + "J u" #'gnus-agent-fetch-groups + "J c" #'gnus-enter-category-buffer + "J j" #'gnus-agent-toggle-plugged + "J s" #'gnus-agent-fetch-session + "J Y" #'gnus-agent-synchronize-flags + "J S" #'gnus-group-send-queue + "J a" #'gnus-agent-add-group + "J r" #'gnus-agent-remove-group + "J o" #'gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -504,14 +504,14 @@ manipulated as follows: )))) (defvar-keymap gnus-agent-summary-mode-map - "Jj" #'gnus-agent-toggle-plugged - "Ju" #'gnus-agent-summary-fetch-group - "JS" #'gnus-agent-fetch-group - "Js" #'gnus-agent-summary-fetch-series - "J#" #'gnus-agent-mark-article - "J\M-#" #'gnus-agent-unmark-article + "J j" #'gnus-agent-toggle-plugged + "J u" #'gnus-agent-summary-fetch-group + "J S" #'gnus-agent-fetch-group + "J s" #'gnus-agent-summary-fetch-series + "J #" #'gnus-agent-mark-article + "J M-#" #'gnus-agent-unmark-article "@" #'gnus-agent-toggle-mark - "Jc" #'gnus-agent-catchup) + "J c" #'gnus-agent-catchup) (defun gnus-agent-summary-make-menu-bar () (unless (boundp 'gnus-agent-summary-menu) @@ -526,9 +526,9 @@ manipulated as follows: ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar-keymap gnus-agent-server-mode-map - "Jj" #'gnus-agent-toggle-plugged - "Ja" #'gnus-agent-add-server - "Jr" #'gnus-agent-remove-server) + "J j" #'gnus-agent-toggle-plugged + "J a" #'gnus-agent-add-server + "J r" #'gnus-agent-remove-server) (defun gnus-agent-server-make-menu-bar () (unless (boundp 'gnus-agent-server-menu) @@ -2606,8 +2606,8 @@ General format specifiers can also be used. See Info node "s" #'gnus-category-edit-score "l" #'gnus-category-list - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug) + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defcustom gnus-category-menu-hook nil "Hook run after the creation of the menu." diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 78ce89dde3c..02f0d50be5d 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -768,28 +768,37 @@ Obsolete; use the face `gnus-signature' for customizations instead." :group 'gnus-article-highlight :group 'gnus-article-signature) +(defface gnus-header + '((t nil)) + "Base face used for all Gnus header faces. +All the other `gnus-header-' faces inherit from this face." + :version "29.1" + :group 'gnus-article-headers + :group 'gnus-article-highlight) + (defface gnus-header-from '((((class color) (background dark)) - (:foreground "PaleGreen1")) + (:foreground "PaleGreen1" :inherit gnus-header)) (((class color) (background light)) - (:foreground "red3")) + (:foreground "red3" :inherit gnus-header)) (t - (:italic t))) + (:italic t :inherit gnus-header))) "Face used for displaying from headers." + :version "29.1" :group 'gnus-article-headers :group 'gnus-article-highlight) (defface gnus-header-subject '((((class color) (background dark)) - (:foreground "SeaGreen1")) + (:foreground "SeaGreen1" :inherit gnus-header)) (((class color) (background light)) - (:foreground "red4")) + (:foreground "red4" :inherit gnus-header)) (t - (:bold t :italic t))) + (:bold t :italic t :inherit gnus-header))) "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -797,7 +806,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." (defface gnus-header-newsgroups '((((class color) (background dark)) - (:foreground "yellow" :italic t)) + (:foreground "yellow" :italic t :inherit gnus-header)) (((class color) (background light)) (:foreground "MidnightBlue" :italic t)) @@ -812,12 +821,12 @@ articles." (defface gnus-header-name '((((class color) (background dark)) - (:foreground "SpringGreen2")) + (:foreground "SpringGreen2" :inherit gnus-header)) (((class color) (background light)) - (:foreground "maroon")) + (:foreground "maroon" :inherit gnus-header)) (t - (:bold t))) + (:bold t :inherit gnus-header))) "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -825,12 +834,13 @@ articles." (defface gnus-header-content '((((class color) (background dark)) - (:foreground "SpringGreen1" :italic t)) + (:foreground "SpringGreen1" :italic t :inherit gnus-header)) (((class color) (background light)) - (:foreground "indianred4" :italic t)) + (:foreground "indianred4" :italic t :inherit gnus-header)) (t - (:italic t))) "Face used for displaying header content." + (:italic t :inherit gnus-header))) + "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -4419,36 +4429,36 @@ If variable `gnus-use-long-file-name' is non-nil, it is (define-keymap :keymap gnus-article-mode-map :suppress t :parent button-buffer-map - " " #'gnus-article-goto-next-page - [?\S-\ ] #'gnus-article-goto-prev-page - "\177" #'gnus-article-goto-prev-page - [delete] #'gnus-article-goto-prev-page - "\C-c^" #'gnus-article-refer-article + "SPC" #'gnus-article-goto-next-page + "S-SPC" #'gnus-article-goto-prev-page + "DEL" #'gnus-article-goto-prev-page + "" #'gnus-article-goto-prev-page + "C-c ^" #'gnus-article-refer-article "h" #'gnus-article-show-summary "s" #'gnus-article-show-summary - "\C-c\C-m" #'gnus-article-mail + "C-c C-m" #'gnus-article-mail "?" #'gnus-article-describe-briefly "<" #'beginning-of-buffer ">" #'end-of-buffer - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug "R" #'gnus-article-reply-with-original "F" #'gnus-article-followup-with-original - "\C-hk" #'gnus-article-describe-key - "\C-hc" #'gnus-article-describe-key-briefly - "\C-hb" #'gnus-article-describe-bindings + "C-h k" #'gnus-article-describe-key + "C-h c" #'gnus-article-describe-key-briefly + "C-h b" #'gnus-article-describe-bindings "e" #'gnus-article-read-summary-keys - "\C-d" #'gnus-article-read-summary-keys - "\C-c\C-f" #'gnus-summary-mail-forward - "\M-*" #'gnus-article-read-summary-keys - "\M-#" #'gnus-article-read-summary-keys - "\M-^" #'gnus-article-read-summary-keys - "\M-g" #'gnus-article-read-summary-keys + "C-d" #'gnus-article-read-summary-keys + "C-c C-f" #'gnus-summary-mail-forward + "M-*" #'gnus-article-read-summary-keys + "M-#" #'gnus-article-read-summary-keys + "M-^" #'gnus-article-read-summary-keys + "M-g" #'gnus-article-read-summary-keys "S" (define-keymap :prefix 'gnus-article-send-map "W" #'gnus-article-wide-reply-with-original - [t] #'gnus-article-read-summary-send-keys)) + "" #'gnus-article-read-summary-send-keys)) (substitute-key-definition #'undefined #'gnus-article-read-summary-keys gnus-article-mode-map) @@ -6897,8 +6907,8 @@ KEY is a string or a vector." unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) - (describe-key (cons (read-key-sequence nil t) - (this-single-command-raw-keys)) + (describe-key (list (cons (read-key-sequence nil t) + (this-single-command-raw-keys))) (current-buffer)))) (describe-key key))) @@ -6922,8 +6932,8 @@ KEY is a string or a vector." unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) - (describe-key-briefly (cons (read-key-sequence nil t) - (this-single-command-raw-keys)) + (describe-key-briefly (list (cons (read-key-sequence nil t) + (this-single-command-raw-keys))) insert (current-buffer)))) (describe-key-briefly key insert))) @@ -7254,41 +7264,40 @@ other groups." (defvar-keymap gnus-article-edit-mode-map :full t :parent text-mode-map - "\C-c?" #'describe-mode - "\C-c\C-c" #'gnus-article-edit-done - "\C-c\C-k" #'gnus-article-edit-exit - "\C-c\C-f\C-t" #'message-goto-to - "\C-c\C-f\C-o" #'message-goto-from - "\C-c\C-f\C-b" #'message-goto-bcc - ;;"\C-c\C-f\C-w" message-goto-fcc - "\C-c\C-f\C-c" #'message-goto-cc - "\C-c\C-f\C-s" #'message-goto-subject - "\C-c\C-f\C-r" #'message-goto-reply-to - "\C-c\C-f\C-n" #'message-goto-newsgroups - "\C-c\C-f\C-d" #'message-goto-distribution - "\C-c\C-f\C-f" #'message-goto-followup-to - "\C-c\C-f\C-m" #'message-goto-mail-followup-to - "\C-c\C-f\C-k" #'message-goto-keywords - "\C-c\C-f\C-u" #'message-goto-summary - "\C-c\C-f\C-i" #'message-insert-or-toggle-importance - "\C-c\C-f\C-a" #'message-generate-unsubscribed-mail-followup-to - "\C-c\C-b" #'message-goto-body - "\C-c\C-i" #'message-goto-signature + "C-c ?" #'describe-mode + "C-c C-c" #'gnus-article-edit-done + "C-c C-k" #'gnus-article-edit-exit + "C-c C-f C-t" #'message-goto-to + "C-c C-f C-o" #'message-goto-from + "C-c C-f C-b" #'message-goto-bcc + "C-c C-f C-c" #'message-goto-cc + "C-c C-f C-s" #'message-goto-subject + "C-c C-f C-r" #'message-goto-reply-to + "C-c C-f C-n" #'message-goto-newsgroups + "C-c C-f C-d" #'message-goto-distribution + "C-c C-f C-f" #'message-goto-followup-to + "C-c C-f RET" #'message-goto-mail-followup-to + "C-c C-f C-k" #'message-goto-keywords + "C-c C-f C-u" #'message-goto-summary + "C-c C-f TAB" #'message-insert-or-toggle-importance + "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to + "C-c C-b" #'message-goto-body + "C-c TAB" #'message-goto-signature - "\C-c\C-t" #'message-insert-to - "\C-c\C-n" #'message-insert-newsgroups - "\C-c\C-o" #'message-sort-headers - "\C-c\C-e" #'message-elide-region - "\C-c\C-v" #'message-delete-not-region - "\C-c\C-z" #'message-kill-to-signature - "\M-\r" #'message-newline-and-reformat - "\C-c\C-a" #'mml-attach-file - "\C-a" #'message-beginning-of-line - "\t" #'message-tab - "\M-;" #'comment-region + "C-c C-t" #'message-insert-to + "C-c C-n" #'message-insert-newsgroups + "C-c C-o" #'message-sort-headers + "C-c C-e" #'message-elide-region + "C-c C-v" #'message-delete-not-region + "C-c C-z" #'message-kill-to-signature + "M-RET" #'message-newline-and-reformat + "C-c C-a" #'mml-attach-file + "C-a" #'message-beginning-of-line + "TAB" #'message-tab + "M-;" #'comment-region - "\C-c\C-w" (define-keymap :prefix 'gnus-article-edit-wash-map - "f" #'gnus-article-edit-full-stops)) + "C-c C-w" (define-keymap :prefix 'gnus-article-edit-wash-map + "f" #'gnus-article-edit-full-stops)) (easy-menu-define gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 171da9d17a0..e9696b66a9f 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -423,16 +423,16 @@ That is, all information but the name." :full t :suppress 'nodigits "q" #'quit-window - "\C-m" #'gnus-bookmark-bmenu-select + "RET" #'gnus-bookmark-bmenu-select "v" #'gnus-bookmark-bmenu-select "d" #'gnus-bookmark-bmenu-delete "k" #'gnus-bookmark-bmenu-delete - "\C-d" #'gnus-bookmark-bmenu-delete-backwards + "C-d" #'gnus-bookmark-bmenu-delete-backwards "x" #'gnus-bookmark-bmenu-execute-deletions - " " #'next-line + "SPC" #'next-line "n" #'next-line "p" #'previous-line - "\177" #'gnus-bookmark-bmenu-backup-unmark + "DEL" #'gnus-bookmark-bmenu-backup-unmark "?" #'describe-mode "u" #'gnus-bookmark-bmenu-unmark "m" #'gnus-bookmark-bmenu-mark @@ -440,7 +440,7 @@ That is, all information but the name." "s" #'gnus-bookmark-bmenu-save "t" #'gnus-bookmark-bmenu-toggle-infos "a" #'gnus-bookmark-bmenu-show-details - [mouse-2] #'gnus-bookmark-bmenu-select-by-mouse) + "" #'gnus-bookmark-bmenu-select-by-mouse) ;; Bookmark Buffer Menu mode is suitable only for specially formatted ;; data. diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index be46d3a341d..00769a5da6e 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -54,9 +54,9 @@ (autoload 'gnus-print-buffer "gnus-sum") (defvar-keymap gnus-dired-mode-map - "\C-c\C-m\C-a" #'gnus-dired-attach - "\C-c\C-m\C-l" #'gnus-dired-find-file-mailcap - "\C-c\C-m\C-p" #'gnus-dired-print) + "C-c C-m C-a" #'gnus-dired-attach + "C-c C-m C-l" #'gnus-dired-find-file-mailcap + "C-c C-m C-p" #'gnus-dired-print) ;; FIXME: Make it customizable, change the default to `mail-user-agent' when ;; this file is renamed (e.g. to `dired-mime.el'). @@ -204,7 +204,8 @@ If ARG is non-nil, open it in a new buffer." (find-file file-name))) (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") - (error "File no longer exists; type `g' to update Dired buffer")))) + (error (substitute-command-keys + "File no longer exists; type \\`g' to update Dired buffer"))))) (defun gnus-dired-print (&optional file-name print-to) "In dired, print FILE-NAME according to the mailcap file. @@ -244,9 +245,10 @@ of the file to save in." (error "MIME print only implemented via Gnus"))) (ps-despool print-to)))) ((file-symlink-p file-name) - (error "File is a symlink to a nonexistent target")) - (t - (error "File no longer exists; type `g' to update Dired buffer")))) + (error "File is a symlink to a nonexistent target")) + (t + (error (substitute-command-keys + "File no longer exists; type \\`g' to update Dired buffer"))))) (provide 'gnus-dired) diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 756e6d2d362..7c56db0ba45 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -34,11 +34,11 @@ ;;; Draft minor mode (defvar-keymap gnus-draft-mode-map - "Dt" #'gnus-draft-toggle-sending + "D t" #'gnus-draft-toggle-sending "e" #' gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' - "De" #'gnus-draft-edit-message - "Ds" #'gnus-draft-send-message - "DS" #'gnus-draft-send-all-messages) + "D e" #'gnus-draft-edit-message + "D s" #'gnus-draft-send-message + "D S" #'gnus-draft-send-all-messages) (defun gnus-draft-make-menu-bar () (unless (boundp 'gnus-draft-menu) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index b0aa58f0f28..c727926731b 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,8 +50,8 @@ (defvar-keymap gnus-edit-form-mode-map :parent emacs-lisp-mode-map - "\C-c\C-c" #'gnus-edit-form-done - "\C-c\C-k" #'gnus-edit-form-exit) + "C-c C-c" #'gnus-edit-form-done + "C-c C-k" #'gnus-edit-form-exit) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index ddc819877c1..2ec001faee7 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -62,7 +62,7 @@ (defcustom gnus-keep-same-level nil "Non-nil means that the newsgroup after this one will be on the same level. -When you type, for instance, `n' after reading the last article in the +When you type, for instance, \\`n' after reading the last article in the current newsgroup, you will go to the next newsgroup. If this variable is nil, the next newsgroup will be the next from the group buffer. @@ -574,79 +574,79 @@ simple manner." ;;; (define-keymap :keymap gnus-group-mode-map - " " #'gnus-group-read-group + "SPC" #'gnus-group-read-group "=" #'gnus-group-select-group - "\r" #'gnus-group-select-group - "\M-\r" #'gnus-group-quick-select-group - "\M- " #'gnus-group-visible-select-group - [(meta control return)] #'gnus-group-select-group-ephemerally + "RET" #'gnus-group-select-group + "M-RET" #'gnus-group-quick-select-group + "M-SPC" #'gnus-group-visible-select-group + "C-M-" #'gnus-group-select-group-ephemerally "j" #'gnus-group-jump-to-group "n" #'gnus-group-next-unread-group "p" #'gnus-group-prev-unread-group - "\177" #'gnus-group-prev-unread-group - [delete] #'gnus-group-prev-unread-group + "DEL" #'gnus-group-prev-unread-group + "" #'gnus-group-prev-unread-group "N" #'gnus-group-next-group "P" #'gnus-group-prev-group - "\M-n" #'gnus-group-next-unread-group-same-level - "\M-p" #'gnus-group-prev-unread-group-same-level + "M-n" #'gnus-group-next-unread-group-same-level + "M-p" #'gnus-group-prev-unread-group-same-level "," #'gnus-group-best-unread-group "." #'gnus-group-first-unread-group "u" #'gnus-group-toggle-subscription-at-point "U" #'gnus-group-toggle-subscription "c" #'gnus-group-catchup-current "C" #'gnus-group-catchup-current-all - "\M-c" #'gnus-group-clear-data + "M-c" #'gnus-group-clear-data "l" #'gnus-group-list-groups "L" #'gnus-group-list-all-groups "m" #'gnus-group-mail "i" #'gnus-group-news "g" #'gnus-group-get-new-news - "\M-g" #'gnus-group-get-new-news-this-group + "M-g" #'gnus-group-get-new-news-this-group "R" #'gnus-group-restart "r" #'gnus-group-read-init-file "B" #'gnus-group-browse-foreign-server "b" #'gnus-group-check-bogus-groups "F" #'gnus-group-find-new-groups - "\C-c\C-d" #'gnus-group-describe-group - "\M-d" #'gnus-group-describe-all-groups - "\C-c\C-a" #'gnus-group-apropos - "\C-c\M-\C-a" #'gnus-group-description-apropos + "C-c C-d" #'gnus-group-describe-group + "M-d" #'gnus-group-describe-all-groups + "C-c C-a" #'gnus-group-apropos + "C-c C-M-a" #'gnus-group-description-apropos "a" #'gnus-group-post-news - "\ek" #'gnus-group-edit-local-kill - "\eK" #'gnus-group-edit-global-kill - "\C-k" #'gnus-group-kill-group - "\C-y" #'gnus-group-yank-group - "\C-w" #'gnus-group-kill-region - "\C-x\C-t" #'gnus-group-transpose-groups - "\C-c\C-l" #'gnus-group-list-killed - "\C-c\C-x" #'gnus-group-expire-articles - "\C-c\M-\C-x" #'gnus-group-expire-all-groups + "ESC k" #'gnus-group-edit-local-kill + "ESC K" #'gnus-group-edit-global-kill + "C-k" #'gnus-group-kill-group + "C-y" #'gnus-group-yank-group + "C-w" #'gnus-group-kill-region + "C-x C-t" #'gnus-group-transpose-groups + "C-c C-l" #'gnus-group-list-killed + "C-c C-x" #'gnus-group-expire-articles + "C-c C-M-x" #'gnus-group-expire-all-groups "V" #'gnus-version "s" #'gnus-group-save-newsrc "z" #'gnus-group-suspend "q" #'gnus-group-exit "Q" #'gnus-group-quit "?" #'gnus-group-describe-briefly - "\C-c\C-i" #'gnus-info-find-node - "\M-e" #'gnus-group-edit-group-method + "C-c C-i" #'gnus-info-find-node + "M-e" #'gnus-group-edit-group-method "^" #'gnus-group-enter-server-mode - [mouse-2] #'gnus-mouse-pick-group - [follow-link] 'mouse-face + "" #'gnus-mouse-pick-group + "" 'mouse-face "<" #'beginning-of-buffer ">" #'end-of-buffer - "\C-c\C-b" #'gnus-bug - "\C-c\C-s" #'gnus-group-sort-groups + "C-c C-b" #'gnus-bug + "C-c C-s" #'gnus-group-sort-groups "t" #'gnus-topic-mode - "\C-c\M-g" #'gnus-activate-all-groups - "\M-&" #'gnus-group-universal-argument + "C-c M-g" #'gnus-activate-all-groups + "M-&" #'gnus-group-universal-argument "#" #'gnus-group-mark-group - "\M-#" #'gnus-group-unmark-group + "M-#" #'gnus-group-unmark-group "~" (define-keymap :prefix 'gnus-group-cloud-map "u" #'gnus-cloud-upload-all-data "~" #'gnus-cloud-upload-all-data "d" #'gnus-cloud-download-all-data - "\r" #'gnus-cloud-download-all-data) + "RET" #'gnus-cloud-download-all-data) "M" (define-keymap :prefix 'gnus-group-mark-map "m" #'gnus-group-mark-group @@ -682,8 +682,8 @@ simple manner." "c" #'gnus-group-customize "z" #'gnus-group-compact-group "x" #'gnus-group-expunge-group - "\177" #'gnus-group-delete-group - [delete] #'gnus-group-delete-group + "DEL" #'gnus-group-delete-group + "" #'gnus-group-delete-group "S" (define-keymap :prefix 'gnus-group-sort-map "s" #'gnus-group-sort-groups @@ -774,7 +774,7 @@ simple manner." "k" #'gnus-group-kill-group "y" #'gnus-group-yank-group "w" #'gnus-group-kill-region - "\C-k" #'gnus-group-kill-level + "C-k" #'gnus-group-kill-level "z" #'gnus-group-kill-all-zombies)) (defun gnus-topic-mode-p () diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index c1815d3486c..ef376f138e7 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -79,9 +79,9 @@ fit these criteria." (defvar-keymap gnus-html-displayed-image-map "a" #'gnus-html-show-alt-text "i" #'gnus-html-browse-image - "\r" #'gnus-html-browse-url + "RET" #'gnus-html-browse-url "u" #'gnus-article-copy-string - [tab] #'forward-button) + "" #'forward-button) (defun gnus-html-encode-url (url) "Encode URL." diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 7e589c54e97..7137efd7309 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -68,13 +68,13 @@ of time." (defvar-keymap gnus-kill-file-mode-map :parent emacs-lisp-mode-map - "\C-c\C-k\C-s" #'gnus-kill-file-kill-by-subject - "\C-c\C-k\C-a" #'gnus-kill-file-kill-by-author - "\C-c\C-k\C-t" #'gnus-kill-file-kill-by-thread - "\C-c\C-k\C-x" #'gnus-kill-file-kill-by-xref - "\C-c\C-a" #'gnus-kill-file-apply-buffer - "\C-c\C-e" #'gnus-kill-file-apply-last-sexp - "\C-c\C-c" #'gnus-kill-file-exit) + "C-c C-k C-s" #'gnus-kill-file-kill-by-subject + "C-c C-k C-a" #'gnus-kill-file-kill-by-author + "C-c C-k C-t" #'gnus-kill-file-kill-by-thread + "C-c C-k C-x" #'gnus-kill-file-kill-by-xref + "C-c C-a" #'gnus-kill-file-apply-buffer + "C-c C-e" #'gnus-kill-file-apply-last-sexp + "C-c C-c" #'gnus-kill-file-exit) (define-derived-mode gnus-kill-file-mode emacs-lisp-mode "Kill" "Major mode for editing kill files. diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index bf33194cf75..a5358e9ff42 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -32,12 +32,12 @@ ;;; Mailing list minor mode (defvar-keymap gnus-mailing-list-mode-map - "\C-c\C-nh" #'gnus-mailing-list-help - "\C-c\C-ns" #'gnus-mailing-list-subscribe - "\C-c\C-nu" #'gnus-mailing-list-unsubscribe - "\C-c\C-np" #'gnus-mailing-list-post - "\C-c\C-no" #'gnus-mailing-list-owner - "\C-c\C-na" #'gnus-mailing-list-archive) + "C-c C-n h" #'gnus-mailing-list-help + "C-c C-n s" #'gnus-mailing-list-subscribe + "C-c C-n u" #'gnus-mailing-list-unsubscribe + "C-c C-n p" #'gnus-mailing-list-post + "C-c C-n o" #'gnus-mailing-list-owner + "C-c C-n a" #'gnus-mailing-list-archive) (defvar gnus-mailing-list-menu) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index e88aa8f7d09..bb265642bc6 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -369,13 +369,13 @@ only affect the Gcc copy, but not the original message." "m" #'gnus-summary-mail-other-window "u" #'gnus-uu-post-news "A" #'gnus-summary-attach-article - "\M-c" #'gnus-summary-mail-crosspost-complaint - "Br" #'gnus-summary-reply-broken-reply-to - "BR" #'gnus-summary-reply-broken-reply-to-with-original - "om" #'gnus-summary-mail-forward - "op" #'gnus-summary-post-forward - "Om" #'gnus-uu-digest-mail-forward - "Op" #'gnus-uu-digest-post-forward + "M-c" #'gnus-summary-mail-crosspost-complaint + "B r" #'gnus-summary-reply-broken-reply-to + "B R" #'gnus-summary-reply-broken-reply-to-with-original + "o m" #'gnus-summary-mail-forward + "o p" #'gnus-summary-post-forward + "O m" #'gnus-uu-digest-mail-forward + "O p" #'gnus-uu-digest-post-forward "D" (define-keymap :prefix 'gnus-send-bounce-map "b" #'gnus-summary-resend-bounced-mail @@ -1305,7 +1305,7 @@ For the \"inline\" alternatives, also see the variable (gnus-inews-insert-gcc) (let ((gcc (message-unquote-tokens (message-tokenize-header (mail-fetch-field "gcc" nil t) - " ,"))) + ","))) (self (with-current-buffer gnus-summary-buffer gnus-gcc-self-resent-messages))) (message-remove-header "gcc") @@ -1572,7 +1572,7 @@ this is a reply." (message-remove-header "gcc") (widen) (setq groups (message-unquote-tokens - (message-tokenize-header gcc " ,\n\t"))) + (message-tokenize-header gcc ",\n\t"))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group)) diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index 8ffe4a4c573..205e936bc7e 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -65,11 +65,11 @@ It accepts the same format specs that `gnus-summary-line-format' does." ;;; Internal variables. (defvar-keymap gnus-pick-mode-map - " " #'gnus-pick-next-page + "SPC" #'gnus-pick-next-page "u" #'gnus-pick-unmark-article-or-thread "." #'gnus-pick-article-or-thread - [down-mouse-2] #'gnus-pick-mouse-pick-region - "\r" #'gnus-pick-start-reading) + "" #'gnus-pick-mouse-pick-region + "RET" #'gnus-pick-start-reading) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) @@ -420,12 +420,12 @@ Two predefined functions are available: (defvar-keymap gnus-tree-mode-map :full t :suppress t - "\r" #'gnus-tree-select-article - [mouse-2] #'gnus-tree-pick-article - "\C-?" #'gnus-tree-read-summary-keys + "RET" #'gnus-tree-select-article + "" #'gnus-tree-pick-article + "DEL" #'gnus-tree-read-summary-keys "h" #'gnus-tree-show-summary - "\C-c\C-i" #'gnus-info-find-node) + "C-c C-i" #'gnus-info-find-node) (substitute-key-definition 'undefined #'gnus-tree-read-summary-keys gnus-tree-mode-map) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 2ca25802957..d031047804a 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -2562,16 +2562,17 @@ score in `gnus-newsgroup-scored' by SCORE." (or (caddr s) gnus-score-interactive-default-score)) trace)))) - (insert - "\n\nQuick help: + (insert + (substitute-command-keys + "\n\nQuick help: -Type `e' to edit score file corresponding to the score rule on current line, -`f' to format (pretty print) the score file and edit it, -`t' toggle to truncate long lines in this buffer, -`q' to quit, `k' to kill score trace buffer. +Type \\`e' to edit score file corresponding to the score rule on current line, +\\`f' to format (pretty print) the score file and edit it, +\\`t' toggle to truncate long lines in this buffer, +\\`q' to quit, \\`k' to kill score trace buffer. The first sexp on each line is the score rule, followed by the file name of -the score file and its full name, including the directory.") +the score file and its full name, including the directory.")) (goto-char (point-min)) (gnus-configure-windows 'score-trace))) (set-buffer gnus-summary-buffer) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f2ffb067b8e..fa880b7eddb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -105,9 +105,9 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar-keymap gnus-server-mode-map :full t :suppress t - " " #'gnus-server-read-server-in-server-buffer - "\r" #'gnus-server-read-server - [mouse-2] #'gnus-server-pick-server + "SPC" #'gnus-server-read-server-in-server-buffer + "RET" #'gnus-server-read-server + "" #'gnus-server-pick-server "q" #'gnus-server-exit "l" #'gnus-server-list-servers "k" #'gnus-server-kill-server @@ -119,9 +119,9 @@ If nil, a faster, but more primitive, buffer is used instead." "s" #'gnus-server-scan-server "O" #'gnus-server-open-server - "\M-o" #'gnus-server-open-all-servers + "M-o" #'gnus-server-open-all-servers "C" #'gnus-server-close-server - "\M-c" #'gnus-server-close-all-servers + "M-c" #'gnus-server-close-all-servers "D" #'gnus-server-deny-server "L" #'gnus-server-offline-server "R" #'gnus-server-remove-denials @@ -138,8 +138,8 @@ If nil, a faster, but more primitive, buffer is used instead." "i" #'gnus-server-toggle-cloud-server "I" #'gnus-server-set-cloud-method-server - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug) + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defcustom gnus-server-menu-hook nil "Hook run after the creation of the server mode menu." @@ -694,29 +694,29 @@ claim them." (defvar-keymap gnus-browse-mode-map :full t :suppress t - " " #'gnus-browse-read-group + "SPC" #'gnus-browse-read-group "=" #'gnus-browse-select-group "n" #'gnus-browse-next-group "p" #'gnus-browse-prev-group - "\177" #'gnus-browse-prev-group - [delete] #'gnus-browse-prev-group + "DEL" #'gnus-browse-prev-group + "" #'gnus-browse-prev-group "N" #'gnus-browse-next-group "P" #'gnus-browse-prev-group - "\M-n" #'gnus-browse-next-group - "\M-p" #'gnus-browse-prev-group - "\r" #'gnus-browse-select-group + "M-n" #'gnus-browse-next-group + "M-p" #'gnus-browse-prev-group + "RET" #'gnus-browse-select-group "u" #'gnus-browse-toggle-subscription-at-point "l" #'gnus-browse-exit "L" #'gnus-browse-exit "q" #'gnus-browse-exit "Q" #'gnus-browse-exit "d" #'gnus-browse-describe-group - [delete] #'gnus-browse-delete-group - "\C-c\C-c" #'gnus-browse-exit + "" #'gnus-browse-delete-group + "C-c C-c" #'gnus-browse-exit "?" #'gnus-browse-describe-briefly - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug) + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defun gnus-browse-make-menu-bar () (gnus-turn-off-edit-menu 'browse) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index f06661209bd..dcdf3d977df 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1908,129 +1908,129 @@ increase the score of each group you read." ;; Non-orthogonal keys (define-keymap :keymap gnus-summary-mode-map - " " #'gnus-summary-next-page - [?\S-\ ] #'gnus-summary-prev-page - "\177" #'gnus-summary-prev-page - [delete] #'gnus-summary-prev-page - "\r" #'gnus-summary-scroll-up - "\M-\r" #'gnus-summary-scroll-down + "SPC" #'gnus-summary-next-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "" #'gnus-summary-prev-page + "RET" #'gnus-summary-scroll-up + "M-RET" #'gnus-summary-scroll-down "n" #'gnus-summary-next-unread-article "p" #'gnus-summary-prev-unread-article "N" #'gnus-summary-next-article "P" #'gnus-summary-prev-article - "\M-\C-n" #'gnus-summary-next-same-subject - "\M-\C-p" #'gnus-summary-prev-same-subject - "\M-n" #'gnus-summary-next-unread-subject - "\M-p" #'gnus-summary-prev-unread-subject + "C-M-n" #'gnus-summary-next-same-subject + "C-M-p" #'gnus-summary-prev-same-subject + "M-n" #'gnus-summary-next-unread-subject + "M-p" #'gnus-summary-prev-unread-subject "." #'gnus-summary-first-unread-article "," #'gnus-summary-best-unread-article "[" #'gnus-summary-prev-unseen-article "]" #'gnus-summary-next-unseen-article - "\M-s\M-s" #'gnus-summary-search-article-forward - "\M-s\M-r" #'gnus-summary-search-article-backward - "\M-r" #'gnus-summary-search-article-backward - "\M-S" #'gnus-summary-repeat-search-article-forward - "\M-R" #'gnus-summary-repeat-search-article-backward + "M-s M-s" #'gnus-summary-search-article-forward + "M-s M-r" #'gnus-summary-search-article-backward + "M-r" #'gnus-summary-search-article-backward + "M-S" #'gnus-summary-repeat-search-article-forward + "M-R" #'gnus-summary-repeat-search-article-backward "<" #'gnus-summary-beginning-of-article ">" #'gnus-summary-end-of-article "j" #'gnus-summary-goto-article "^" #'gnus-summary-refer-parent-article - "\M-^" #'gnus-summary-refer-article + "M-^" #'gnus-summary-refer-article "u" #'gnus-summary-tick-article-forward "!" #'gnus-summary-tick-article-forward "U" #'gnus-summary-tick-article-backward "d" #'gnus-summary-mark-as-read-forward "D" #'gnus-summary-mark-as-read-backward "E" #'gnus-summary-mark-as-expirable - "\M-u" #'gnus-summary-clear-mark-forward - "\M-U" #'gnus-summary-clear-mark-backward + "M-u" #'gnus-summary-clear-mark-forward + "M-U" #'gnus-summary-clear-mark-backward "k" #'gnus-summary-kill-same-subject-and-select - "\C-k" #'gnus-summary-kill-same-subject - "\M-\C-k" #'gnus-summary-kill-thread - "\M-\C-l" #'gnus-summary-lower-thread + "C-k" #'gnus-summary-kill-same-subject + "C-M-k" #'gnus-summary-kill-thread + "C-M-l" #'gnus-summary-lower-thread "e" #'gnus-summary-edit-article "#" #'gnus-summary-mark-as-processable - "\M-#" #'gnus-summary-unmark-as-processable - "\M-\C-t" #'gnus-summary-toggle-threads - "\M-\C-s" #'gnus-summary-show-thread - "\M-\C-h" #'gnus-summary-hide-thread - "\M-\C-f" #'gnus-summary-next-thread - "\M-\C-b" #'gnus-summary-prev-thread - [(meta down)] #'gnus-summary-next-thread - [(meta up)] #'gnus-summary-prev-thread - "\M-\C-u" #'gnus-summary-up-thread - "\M-\C-d" #'gnus-summary-down-thread + "M-#" #'gnus-summary-unmark-as-processable + "C-M-t" #'gnus-summary-toggle-threads + "C-M-s" #'gnus-summary-show-thread + "C-M-h" #'gnus-summary-hide-thread + "C-M-f" #'gnus-summary-next-thread + "C-M-b" #'gnus-summary-prev-thread + "M-" #'gnus-summary-next-thread + "M-" #'gnus-summary-prev-thread + "C-M-u" #'gnus-summary-up-thread + "C-M-d" #'gnus-summary-down-thread "&" #'gnus-summary-execute-command "c" #'gnus-summary-catchup-and-exit - "\C-w" #'gnus-summary-mark-region-as-read - "\C-t" #'toggle-truncate-lines + "C-w" #'gnus-summary-mark-region-as-read + "C-t" #'toggle-truncate-lines "?" #'gnus-summary-mark-as-dormant - "\C-c\M-\C-s" #'gnus-summary-limit-include-expunged - "\C-c\C-s\C-n" #'gnus-summary-sort-by-number - "\C-c\C-s\C-m\C-n" #'gnus-summary-sort-by-most-recent-number - "\C-c\C-s\C-l" #'gnus-summary-sort-by-lines - "\C-c\C-s\C-c" #'gnus-summary-sort-by-chars - "\C-c\C-s\C-m\C-m" #'gnus-summary-sort-by-marks - "\C-c\C-s\C-a" #'gnus-summary-sort-by-author - "\C-c\C-s\C-t" #'gnus-summary-sort-by-recipient - "\C-c\C-s\C-s" #'gnus-summary-sort-by-subject - "\C-c\C-s\C-d" #'gnus-summary-sort-by-date - "\C-c\C-s\C-m\C-d" #'gnus-summary-sort-by-most-recent-date - "\C-c\C-s\C-i" #'gnus-summary-sort-by-score - "\C-c\C-s\C-o" #'gnus-summary-sort-by-original - "\C-c\C-s\C-r" #'gnus-summary-sort-by-random - "\C-c\C-s\C-u" #'gnus-summary-sort-by-newsgroups - "\C-c\C-s\C-x" #'gnus-summary-sort-by-extra + "C-c C-M-s" #'gnus-summary-limit-include-expunged + "C-c C-s C-n" #'gnus-summary-sort-by-number + "C-c C-s C-m C-n" #'gnus-summary-sort-by-most-recent-number + "C-c C-s C-l" #'gnus-summary-sort-by-lines + "C-c C-s C-c" #'gnus-summary-sort-by-chars + "C-c C-s C-m C-m" #'gnus-summary-sort-by-marks + "C-c C-s C-a" #'gnus-summary-sort-by-author + "C-c C-s C-t" #'gnus-summary-sort-by-recipient + "C-c C-s C-s" #'gnus-summary-sort-by-subject + "C-c C-s C-d" #'gnus-summary-sort-by-date + "C-c C-s C-m C-d" #'gnus-summary-sort-by-most-recent-date + "C-c C-s C-i" #'gnus-summary-sort-by-score + "C-c C-s C-o" #'gnus-summary-sort-by-original + "C-c C-s C-r" #'gnus-summary-sort-by-random + "C-c C-s C-u" #'gnus-summary-sort-by-newsgroups + "C-c C-s C-x" #'gnus-summary-sort-by-extra "=" #'gnus-summary-expand-window - "\C-x\C-s" #'gnus-summary-reselect-current-group - "\M-g" #'gnus-summary-rescan-group - "\C-c\C-r" #'gnus-summary-caesar-message + "C-x C-s" #'gnus-summary-reselect-current-group + "M-g" #'gnus-summary-rescan-group + "C-c C-r" #'gnus-summary-caesar-message "f" #'gnus-summary-followup "F" #'gnus-summary-followup-with-original "C" #'gnus-summary-cancel-article "r" #'gnus-summary-reply "R" #'gnus-summary-reply-with-original - "\C-c\C-f" #'gnus-summary-mail-forward + "C-c C-f" #'gnus-summary-mail-forward "o" #'gnus-summary-save-article - "\C-o" #'gnus-summary-save-article-mail + "C-o" #'gnus-summary-save-article-mail "|" #'gnus-summary-pipe-output - "\M-k" #'gnus-summary-edit-local-kill - "\M-K" #'gnus-summary-edit-global-kill + "M-k" #'gnus-summary-edit-local-kill + "M-K" #'gnus-summary-edit-global-kill ;; "V" gnus-version - "\C-c\C-d" #'gnus-summary-describe-group - "\C-c\C-p" #'gnus-summary-make-group-from-search + "C-c C-d" #'gnus-summary-describe-group + "C-c C-p" #'gnus-summary-make-group-from-search "q" #'gnus-summary-exit "Q" #'gnus-summary-exit-no-update - "\C-c\C-i" #'gnus-info-find-node - [mouse-2] #'gnus-mouse-pick-article - [follow-link] 'mouse-face + "C-c C-i" #'gnus-info-find-node + "" #'gnus-mouse-pick-article + "" 'mouse-face "m" #'gnus-summary-mail-other-window "a" #'gnus-summary-post-news "x" #'gnus-summary-limit-to-unread "s" #'gnus-summary-isearch-article - "\t" #'gnus-summary-button-forward - [backtab] #'gnus-summary-button-backward + "TAB" #'gnus-summary-button-forward + "" #'gnus-summary-button-backward "w" #'gnus-summary-browse-url "t" #'gnus-summary-toggle-header "g" #'gnus-summary-show-article "l" #'gnus-summary-goto-last-article - "\C-c\C-v\C-v" #'gnus-uu-decode-uu-view - "\C-d" #'gnus-summary-enter-digest-group - "\M-\C-d" #'gnus-summary-read-document - "\M-\C-e" #'gnus-summary-edit-parameters - "\M-\C-a" #'gnus-summary-customize-parameters - "\C-c\C-b" #'gnus-bug + "C-c C-v C-v" #'gnus-uu-decode-uu-view + "C-d" #'gnus-summary-enter-digest-group + "C-M-d" #'gnus-summary-read-document + "C-M-e" #'gnus-summary-edit-parameters + "C-M-a" #'gnus-summary-customize-parameters + "C-c C-b" #'gnus-bug "*" #'gnus-cache-enter-article - "\M-*" #'gnus-cache-remove-article - "\M-&" #'gnus-summary-universal-argument - "\C-l" #'gnus-recenter + "M-*" #'gnus-cache-remove-article + "M-&" #'gnus-summary-universal-argument + "C-l" #'gnus-recenter "I" #'gnus-summary-increase-score "L" #'gnus-summary-lower-score - "\M-i" #'gnus-symbolic-argument + "M-i" #'gnus-symbolic-argument "h" #'gnus-summary-select-article-buffer "b" #'gnus-article-view-part - "\M-t" #'gnus-summary-toggle-display-buttonized + "M-t" #'gnus-summary-toggle-display-buttonized "S" #'gnus-summary-send-map @@ -2041,19 +2041,19 @@ increase the score of each group you read." "d" #'gnus-summary-mark-as-read-forward "r" #'gnus-summary-mark-as-read-forward "c" #'gnus-summary-clear-mark-forward - " " #'gnus-summary-clear-mark-forward + "SPC" #'gnus-summary-clear-mark-forward "e" #'gnus-summary-mark-as-expirable "x" #'gnus-summary-mark-as-expirable "?" #'gnus-summary-mark-as-dormant "b" #'gnus-summary-set-bookmark "B" #'gnus-summary-remove-bookmark "#" #'gnus-summary-mark-as-processable - "\M-#" #'gnus-summary-unmark-as-processable + "M-#" #'gnus-summary-unmark-as-processable "S" #'gnus-summary-limit-include-expunged "C" #'gnus-summary-catchup "H" #'gnus-summary-catchup-to-here "h" #'gnus-summary-catchup-from-here - "\C-c" #'gnus-summary-catchup-all + "C-c" #'gnus-summary-catchup-all "k" #'gnus-summary-kill-same-subject-and-select "K" #'gnus-summary-kill-same-subject @@ -2118,10 +2118,10 @@ increase the score of each group you read." "p" #'gnus-summary-prev-unread-article "N" #'gnus-summary-next-article "P" #'gnus-summary-prev-article - "\C-n" #'gnus-summary-next-same-subject - "\C-p" #'gnus-summary-prev-same-subject - "\M-n" #'gnus-summary-next-unread-subject - "\M-p" #'gnus-summary-prev-unread-subject + "C-n" #'gnus-summary-next-same-subject + "C-p" #'gnus-summary-prev-same-subject + "M-n" #'gnus-summary-next-unread-subject + "M-p" #'gnus-summary-prev-unread-subject "f" #'gnus-summary-first-unread-article "b" #'gnus-summary-best-unread-article "u" #'gnus-summary-next-unseen-article @@ -2139,7 +2139,7 @@ increase the score of each group you read." "T" #'gnus-summary-toggle-threads "t" #'gnus-summary-rethread-current "^" #'gnus-summary-reparent-thread - "\M-^" #'gnus-summary-reparent-children + "M-^" #'gnus-summary-reparent-children "s" #'gnus-summary-show-thread "S" #'gnus-summary-show-all-threads "h" #'gnus-summary-hide-thread @@ -2150,7 +2150,7 @@ increase the score of each group you read." "o" #'gnus-summary-top-thread "d" #'gnus-summary-down-thread "#" #'gnus-uu-mark-thread - "\M-#" #'gnus-uu-unmark-thread) + "M-#" #'gnus-uu-unmark-thread) "Y" (define-keymap :prefix 'gnus-summary-buffer-map "g" #'gnus-summary-prepare @@ -2173,14 +2173,14 @@ increase the score of each group you read." "P" #'gnus-summary-prev-group) "A" (define-keymap :prefix 'gnus-summary-article-map - " " #'gnus-summary-next-page + "SPC" #'gnus-summary-next-page "n" #'gnus-summary-next-page - [?\S-\ ] #'gnus-summary-prev-page - "\177" #'gnus-summary-prev-page - [delete] #'gnus-summary-prev-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "" #'gnus-summary-prev-page "p" #'gnus-summary-prev-page - "\r" #'gnus-summary-scroll-up - "\M-\r" #'gnus-summary-scroll-down + "RET" #'gnus-summary-scroll-up + "M-RET" #'gnus-summary-scroll-down "<" #'gnus-summary-beginning-of-article ">" #'gnus-summary-end-of-article "b" #'gnus-summary-beginning-of-article @@ -2194,8 +2194,8 @@ increase the score of each group you read." "W" #'gnus-warp-to-article "g" #'gnus-summary-show-article "s" #'gnus-summary-isearch-article - "\t" #'gnus-summary-button-forward - [backtab] #'gnus-summary-button-backward + "TAB" #'gnus-summary-button-forward + "" #'gnus-summary-button-backward "w" #'gnus-summary-browse-url "P" #'gnus-summary-print-article "S" #'gnus-sticky-article @@ -2250,7 +2250,7 @@ increase the score of each group you read." "l" #'gnus-article-hide-list-identifiers "B" #'gnus-article-strip-banner "P" #'gnus-article-hide-pem - "\C-c" #'gnus-article-hide-citation-maybe) + "C-c" #'gnus-article-hide-citation-maybe) "H" (define-keymap :prefix 'gnus-summary-wash-highlight-map "a" #'gnus-article-highlight @@ -2312,10 +2312,10 @@ increase the score of each group you read." "B" (define-keymap :prefix 'gnus-summary-backend-map "e" #'gnus-summary-expire-articles - "\M-\C-e" #'gnus-summary-expire-articles-now - "\177" #'gnus-summary-delete-article - [delete] #'gnus-summary-delete-article - [backspace] #'gnus-summary-delete-article + "C-M-e" #'gnus-summary-expire-articles-now + "DEL" #'gnus-summary-delete-article + "" #'gnus-summary-delete-article + "" #'gnus-summary-delete-article "m" #'gnus-summary-move-article "r" #'gnus-summary-respool-article "w" #'gnus-summary-edit-article diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index e78dd1542c8..0855e98917f 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -1059,26 +1059,26 @@ articles in the topic and its subtopics." (defvar-keymap gnus-topic-mode-map ;; Override certain group mode keys. "=" #'gnus-topic-select-group - "\r" #'gnus-topic-select-group - " " #'gnus-topic-read-group - "\C-c\C-x" #'gnus-topic-expire-articles + "RET" #'gnus-topic-select-group + "SPC" #'gnus-topic-read-group + "C-c C-x" #'gnus-topic-expire-articles "c" #'gnus-topic-catchup-articles - "\C-k" #'gnus-topic-kill-group - "\C-y" #'gnus-topic-yank-group - "\M-g" #'gnus-topic-get-new-news-this-topic - "AT" #'gnus-topic-list-active - "Gp" #'gnus-topic-edit-parameters + "C-k" #'gnus-topic-kill-group + "C-y" #'gnus-topic-yank-group + "M-g" #'gnus-topic-get-new-news-this-topic + "A T" #'gnus-topic-list-active + "G p" #'gnus-topic-edit-parameters "#" #'gnus-topic-mark-topic - "\M-#" #'gnus-topic-unmark-topic - [tab] #'gnus-topic-indent - [(meta tab)] #'gnus-topic-unindent - "\C-i" #'gnus-topic-indent - "\M-\C-i" #'gnus-topic-unindent - [mouse-2] #'gnus-mouse-pick-topic + "M-#" #'gnus-topic-unmark-topic + "" #'gnus-topic-indent + "M-" #'gnus-topic-unindent + "TAB" #'gnus-topic-indent + "C-M-i" #'gnus-topic-unindent + "" #'gnus-mouse-pick-topic "T" (define-keymap :prefix 'gnus-group-topic-map "#" #'gnus-topic-mark-topic - "\M-#" #'gnus-topic-unmark-topic + "M-#" #'gnus-topic-unmark-topic "n" #'gnus-topic-create-topic "m" #'gnus-topic-move-group "D" #'gnus-topic-remove-group @@ -1088,13 +1088,13 @@ articles in the topic and its subtopics." "j" #'gnus-topic-jump-to-topic "M" #'gnus-topic-move-matching "C" #'gnus-topic-copy-matching - "\M-p" #'gnus-topic-goto-previous-topic - "\M-n" #'gnus-topic-goto-next-topic - "\C-i" #'gnus-topic-indent - [tab] #'gnus-topic-indent + "M-p" #'gnus-topic-goto-previous-topic + "M-n" #'gnus-topic-goto-next-topic + "TAB" #'gnus-topic-indent + "" #'gnus-topic-indent "r" #'gnus-topic-rename - "\177" #'gnus-topic-delete - [delete] #'gnus-topic-delete + "DEL" #'gnus-topic-delete + "" #'gnus-topic-delete "H" #'gnus-topic-toggle-display-empty-topics "S" (define-keymap :prefix 'gnus-topic-sort-map diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 0717a7ccfba..a82b1f87a3e 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -76,11 +76,11 @@ ;;; Minor mode definition. (defvar-keymap gnus-undo-mode-map - "\M-\C-_" #'gnus-undo - "\C-_" #'gnus-undo - "\C-xu" #'gnus-undo + "C-M-_" #'gnus-undo + "C-_" #'gnus-undo + "C-x u" #'gnus-undo ;; many people are used to type `C-/' on GUI frames and get `C-_'. - [(control /)] #'gnus-undo) + "C-/" #'gnus-undo) (defun gnus-undo-make-menu-bar () ;; This is disabled for the time being. diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 9b3181fd4d0..56934dfa15d 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1467,11 +1467,11 @@ address was listed in gnus-group-split Addresses (see below).") :variable-group gnus-group-parameter :parameter-type '(gnus-email-address :tag "To List") :parameter-document "\ -This address will be used when doing a `a' in the group. +This address will be used when doing a \\`a' in the group. It is totally ignored when doing a followup--except that if it is present in a news group, you'll get mail group semantics when doing -`f'. +\\`f'. The gnus-group-split mail splitting mechanism will behave as if this address was listed in gnus-group-split Addresses (see below).") @@ -2749,7 +2749,7 @@ with some simple extensions. %F Contents of the From: header (string) %f Contents of the From: or To: headers (string) %x Contents of the Xref: header (string) -%D Date of the article (string) +%D Contents of the Date: header article (string) %d Date of the article (string) in DD-MMM format %o Date of the article (string) in YYYYMMDD`T'HHMMSS format diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 77e8fcdfd16..562bc64f6fb 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -2875,75 +2875,75 @@ Consider adding this function to `message-header-setup-hook'" (defvar-keymap message-mode-map :full t :parent text-mode-map :doc "Message Mode keymap." - "\C-c?" #'describe-mode + "C-c ?" #'describe-mode - "\C-c\C-f\C-t" #'message-goto-to - "\C-c\C-f\C-o" #'message-goto-from - "\C-c\C-f\C-b" #'message-goto-bcc - "\C-c\C-f\C-w" #'message-goto-fcc - "\C-c\C-f\C-c" #'message-goto-cc - "\C-c\C-f\C-s" #'message-goto-subject - "\C-c\C-f\C-r" #'message-goto-reply-to - "\C-c\C-f\C-n" #'message-goto-newsgroups - "\C-c\C-f\C-d" #'message-goto-distribution - "\C-c\C-f\C-f" #'message-goto-followup-to - "\C-c\C-f\C-m" #'message-goto-mail-followup-to - "\C-c\C-f\C-k" #'message-goto-keywords - "\C-c\C-f\C-u" #'message-goto-summary - "\C-c\C-f\C-i" #'message-insert-or-toggle-importance - "\C-c\C-f\C-a" #'message-generate-unsubscribed-mail-followup-to + "C-c C-f C-t" #'message-goto-to + "C-c C-f C-o" #'message-goto-from + "C-c C-f C-b" #'message-goto-bcc + "C-c C-f C-w" #'message-goto-fcc + "C-c C-f C-c" #'message-goto-cc + "C-c C-f C-s" #'message-goto-subject + "C-c C-f C-r" #'message-goto-reply-to + "C-c C-f C-n" #'message-goto-newsgroups + "C-c C-f C-d" #'message-goto-distribution + "C-c C-f C-f" #'message-goto-followup-to + "C-c C-f C-m" #'message-goto-mail-followup-to + "C-c C-f C-k" #'message-goto-keywords + "C-c C-f C-u" #'message-goto-summary + "C-c C-f C-i" #'message-insert-or-toggle-importance + "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to ;; modify headers (and insert notes in body) - "\C-c\C-fs" #'message-change-subject + "C-c C-f s" #'message-change-subject ;; - "\C-c\C-fx" #'message-cross-post-followup-to + "C-c C-f x" #'message-cross-post-followup-to ;; prefix+message-cross-post-followup-to = same w/o cross-post - "\C-c\C-ft" #'message-reduce-to-to-cc - "\C-c\C-fa" #'message-add-archive-header + "C-c C-f t" #'message-reduce-to-to-cc + "C-c C-f a" #'message-add-archive-header ;; mark inserted text - "\C-c\M-m" #'message-mark-inserted-region - "\C-c\M-f" #'message-mark-insert-file + "C-c M-m" #'message-mark-inserted-region + "C-c M-f" #'message-mark-insert-file - "\C-c\C-b" #'message-goto-body - "\C-c\C-i" #'message-goto-signature + "C-c C-b" #'message-goto-body + "C-c C-i" #'message-goto-signature - "\C-c\C-t" #'message-insert-to - "\C-c\C-fw" #'message-insert-wide-reply - "\C-c\C-n" #'message-insert-newsgroups - "\C-c\C-l" #'message-to-list-only - "\C-c\C-f\C-e" #'message-insert-expires - "\C-c\C-u" #'message-insert-or-toggle-importance - "\C-c\M-n" #'message-insert-disposition-notification-to + "C-c C-t" #'message-insert-to + "C-c C-f w" #'message-insert-wide-reply + "C-c C-n" #'message-insert-newsgroups + "C-c C-l" #'message-to-list-only + "C-c C-f C-e" #'message-insert-expires + "C-c C-u" #'message-insert-or-toggle-importance + "C-c M-n" #'message-insert-disposition-notification-to - "\C-c\C-y" #'message-yank-original - "\C-c\M-\C-y" #'message-yank-buffer - "\C-c\C-q" #'message-fill-yanked-message - "\C-c\C-w" #'message-insert-signature - "\C-c\M-h" #'message-insert-headers - "\C-c\C-r" #'message-caesar-buffer-body - "\C-c\C-o" #'message-sort-headers - "\C-c\M-r" #'message-rename-buffer + "C-c C-y" #'message-yank-original + "C-c C-M-y" #'message-yank-buffer + "C-c C-q" #'message-fill-yanked-message + "C-c C-w" #'message-insert-signature + "C-c M-h" #'message-insert-headers + "C-c C-r" #'message-caesar-buffer-body + "C-c C-o" #'message-sort-headers + "C-c M-r" #'message-rename-buffer - "\C-c\C-c" #'message-send-and-exit - "\C-c\C-s" #'message-send - "\C-c\C-k" #'message-kill-buffer - "\C-c\C-d" #'message-dont-send - "\C-c\n" #'gnus-delay-article + "C-c C-c" #'message-send-and-exit + "C-c C-s" #'message-send + "C-c C-k" #'message-kill-buffer + "C-c C-d" #'message-dont-send + "C-c C-j" #'gnus-delay-article - "\C-c\M-k" #'message-kill-address - "\C-c\C-e" #'message-elide-region - "\C-c\C-v" #'message-delete-not-region - "\C-c\C-z" #'message-kill-to-signature - "\M-\r" #'message-newline-and-reformat - [remap split-line] #'message-split-line + "C-c M-k" #'message-kill-address + "C-c C-e" #'message-elide-region + "C-c C-v" #'message-delete-not-region + "C-c C-z" #'message-kill-to-signature + "M-RET" #'message-newline-and-reformat + " " #'message-split-line - "\C-c\C-a" #'mml-attach-file - "\C-c\C-p" #'message-insert-screenshot + "C-c C-a" #'mml-attach-file + "C-c C-p" #'message-insert-screenshot - "\C-a" #'message-beginning-of-line - "\t" #'message-tab + "C-a" #'message-beginning-of-line + "TAB" #'message-tab - "\M-n" #'message-display-abbrev) + "M-n" #'message-display-abbrev) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -4763,23 +4763,25 @@ Valid types are `send', `return', `exit', `kill' and `postpone'." t "\ The message size, " - (/ (buffer-size) 1000) "KB, is too large. + (/ (buffer-size) 1000) + (substitute-command-keys "KB, is too large. Some mail gateways (MTA's) bounce large messages. To avoid the -problem, answer `y', and the message will be split into several -smaller pieces, the size of each is about " +problem, answer \\`y', and the message will be split into several +smaller pieces, the size of each is about ") (/ message-send-mail-partially-limit 1000) - "KB except the last + (substitute-command-keys + "KB except the last one. However, some mail readers (MUA's) can't read split messages, i.e., -mails in message/partially format. Answer `n', and the message +mails in message/partially format. Answer \\`n', and the message will be sent in one piece. The size limit is controlled by `message-send-mail-partially-limit'. If you always want Gnus to send messages in one piece, set `message-send-mail-partially-limit' to nil. -"))) +")))) (progn (message "Sending via mail...") (if message-send-mail-real-function diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index aca4bf2062d..d781407cdcd 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -446,10 +446,11 @@ If not set, `default-directory' will be used." :type 'integer :group 'mime-display) -(defcustom mm-external-terminal-program "xterm" - "The program to start an external terminal." - :version "22.1" - :type 'string +(defcustom mm-external-terminal-program '("xterm" "-e") + "The program to start an external terminal. +This should be a list of strings." + :version "29.1" + :type '(choice string (repeat string)) :group 'mime-display) ;;; Internal variables. @@ -957,10 +958,16 @@ external if displayed external." (unwind-protect (if window-system (set-process-sentinel - (start-process "*display*" nil - mm-external-terminal-program - "-e" shell-file-name - shell-command-switch command) + (apply #'start-process "*display*" nil + (append + (if (listp mm-external-terminal-program) + mm-external-terminal-program + ;; Be backwards-compatible. + (list mm-external-terminal-program + "-e")) + (list shell-file-name + shell-command-switch + command))) (lambda (process _state) (if (eq 'exit (process-status process)) (run-at-time diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 079c1b51225..e60d777e0d2 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -1143,48 +1143,40 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;;; Mode for inserting and editing MML forms ;;; -(defvar mml-mode-map - (let ((sign (make-sparse-keymap)) - (encrypt (make-sparse-keymap)) - (signpart (make-sparse-keymap)) - (encryptpart (make-sparse-keymap)) - (map (make-sparse-keymap)) - (main (make-sparse-keymap))) - (define-key map "\C-s" 'mml-secure-message-sign) - (define-key map "\C-c" 'mml-secure-message-encrypt) - (define-key map "\C-e" 'mml-secure-message-sign-encrypt) - (define-key map "\C-p\C-s" 'mml-secure-sign) - (define-key map "\C-p\C-c" 'mml-secure-encrypt) - (define-key sign "p" 'mml-secure-message-sign-pgpmime) - (define-key sign "o" 'mml-secure-message-sign-pgp) - (define-key sign "s" 'mml-secure-message-sign-smime) - (define-key signpart "p" 'mml-secure-sign-pgpmime) - (define-key signpart "o" 'mml-secure-sign-pgp) - (define-key signpart "s" 'mml-secure-sign-smime) - (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) - (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) - (define-key encrypt "s" 'mml-secure-message-encrypt-smime) - (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime) - (define-key encryptpart "o" 'mml-secure-encrypt-pgp) - (define-key encryptpart "s" 'mml-secure-encrypt-smime) - (define-key map "\C-n" 'mml-unsecure-message) - (define-key map "f" 'mml-attach-file) - (define-key map "b" 'mml-attach-buffer) - (define-key map "e" 'mml-attach-external) - (define-key map "q" 'mml-quote-region) - (define-key map "m" 'mml-insert-multipart) - (define-key map "p" 'mml-insert-part) - (define-key map "v" 'mml-validate) - (define-key map "P" 'mml-preview) - (define-key map "s" sign) - (define-key map "S" signpart) - (define-key map "c" encrypt) - (define-key map "C" encryptpart) - ;;(define-key map "n" 'mml-narrow-to-part) - ;; `M-m' conflicts with `back-to-indentation'. - ;; (define-key main "\M-m" map) - (define-key main "\C-c\C-m" map) - main)) +(defvar-keymap mml-mode-map + "C-c C-m" + (define-keymap + "C-s" #'mml-secure-message-sign + "C-c" #'mml-secure-message-encrypt + "C-e" #'mml-secure-message-sign-encrypt + "C-p C-s" #'mml-secure-sign + "C-p C-c" #'mml-secure-encrypt + + "s" (define-keymap + "p" #'mml-secure-message-sign-pgpmime + "o" #'mml-secure-message-sign-pgp + "s" #'mml-secure-message-sign-smime) + "S" (define-keymap + "p" #'mml-secure-sign-pgpmime + "o" #'mml-secure-sign-pgp + "s" #'mml-secure-sign-smime) + "c" (define-keymap + "p" #'mml-secure-message-encrypt-pgpmime + "o" #'mml-secure-message-encrypt-pgp + "s" #'mml-secure-message-encrypt-smime) + "C" (define-keymap + "p" #'mml-secure-encrypt-pgpmime + "o" #'mml-secure-encrypt-pgp + "s" #'mml-secure-encrypt-smime) + "C-n" #'mml-unsecure-message + "f" #'mml-attach-file + "b" #'mml-attach-buffer + "e" #'mml-attach-external + "q" #'mml-quote-region + "m" #'mml-insert-multipart + "p" #'mml-insert-part + "v" #'mml-validate + "P" #'mml-preview)) (easy-menu-define mml-menu mml-mode-map "" diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index cfef69f1031..508ef5424ea 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -664,11 +664,11 @@ order for SpamAssassin to recognize the new registered spam." ;;; Key bindings for spam control. (define-keymap :keymap gnus-summary-mode-map - "St" #'spam-generic-score - "Sx" #'gnus-summary-mark-as-spam - "Mst" #'spam-generic-score - "Msx" #'gnus-summary-mark-as-spam - "\M-d" #'gnus-summary-mark-as-spam + "S t" #'spam-generic-score + "S x" #'gnus-summary-mark-as-spam + "M s t" #'spam-generic-score + "M s x" #'gnus-summary-mark-as-spam + "M-d" #'gnus-summary-mark-as-spam "$" #'gnus-summary-mark-as-spam) (defvar spam-cache-lookups t diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 1fa9d82afd8..588efee66b1 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -140,6 +140,7 @@ and then returns." (insert (substitute-command-keys help-screen))) (let ((minor-mode-map-alist new-minor-mode-map-alist)) (help-mode) + (variable-pitch-mode) (setq new-minor-mode-map-alist minor-mode-map-alist)) (goto-char (point-min)) (while (or (memq char (append help-event-list diff --git a/lisp/help.el b/lisp/help.el index b2772f4389b..9122d96271d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1078,6 +1078,9 @@ Each substring of the form \\\\=[COMMAND] is replaced by either a keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND is not on any keys. Keybindings will use the face `help-key-binding'. +Each substring of the form \\\\=`KEYBINDING' will be replaced by +KEYBINDING and use the `help-key-binding' face. + Each substring of the form \\\\={MAPVAR} is replaced by a summary of the value of MAPVAR as a keymap. This summary is similar to the one produced by ‘describe-bindings’. The summary ends in two newlines @@ -1130,6 +1133,23 @@ Otherwise, return a new string." (delete-char 2) (ignore-errors (forward-char 1))) + ((and (= (following-char) ?`) + (save-excursion + (prog1 (search-forward "'" nil t) + (setq end-point (- (point) 2))))) + (goto-char orig-point) + (delete-char 2) + (goto-char (1- end-point)) + (delete-char 1) + ;; (backward-char 1) + (let ((k (buffer-substring-no-properties orig-point (point)))) + (cond ((= (length k) 0) + (error "Empty key sequence in substitution")) + ((not (key-valid-p k)) + (error "Invalid key sequence in substitution: `%s'" k)))) + (add-text-properties orig-point (point) + '( face help-key-binding + font-lock-face help-key-binding))) ;; 1C. \[foo] is replaced with the keybinding. ((and (= (following-char) ?\[) (save-excursion @@ -1226,8 +1246,8 @@ Otherwise, return a new string." (buffer-string))))) (defvar help--keymaps-seen nil) -(defun describe-map-tree (startmap partial shadow prefix title no-menu - transl always-title mention-shadow) +(defun describe-map-tree (startmap &optional partial shadow prefix title + no-menu transl always-title mention-shadow) "Insert a description of the key bindings in STARTMAP. This is followed by the key bindings of all maps reachable through STARTMAP. @@ -1328,9 +1348,11 @@ Return nil if the key sequence is too long." (defun help--describe-command (definition &optional translation) (cond ((symbolp definition) - (insert-text-button (symbol-name definition) - 'type 'help-function - 'help-args (list definition)) + (if (fboundp definition) + (insert-text-button (symbol-name definition) + 'type 'help-function + 'help-args (list definition)) + (insert (symbol-name definition))) (insert "\n")) ((or (stringp definition) (vectorp definition)) (if translation @@ -1831,13 +1853,13 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" to delete help window") + "Type \\\\[help-quit] to delete help window") ((eq help-setup 'frame) ;; ... on a new frame, ... - "Type \"q\" to quit the help frame") + "Type \\\\[help-quit] to quit the help frame") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" to restore previous buffer")) + "Type \\\\[help-quit] to restore previous buffer")) window t)) ((and (eq (window-frame window) help-window-old-frame) (= (length (window-list nil 'no-mini)) 2)) @@ -1848,7 +1870,7 @@ Return VALUE." ((eq help-setup 'window) "Type \\[delete-other-windows] to delete the help window") ((eq help-setup 'other) - "Type \"q\" in help window to restore its previous buffer")) + "Type \\\\[help-quit] in help window to restore its previous buffer")) window 'other)) (t ;; The help window is not selected ... @@ -1856,10 +1878,10 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" in help window to delete it") + "Type \\\\[help-quit] in help window to delete it") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" in help window to restore previous buffer")) + "Type \\\\[help-quit] in help window to restore previous buffer")) window)))) ;; Return VALUE. value)) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 5b69a878e21..2d2365dc34d 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1597,7 +1597,10 @@ to move by. The default is `ibuffer-marked-char'." "Hide all of the currently marked lines." (interactive) (if (= (ibuffer-count-marked-lines) 0) - (message "No buffers marked; use `m' to mark a buffer") + (message (substitute-command-keys + (concat + "No buffers marked; use \\" + "\\[ibuffer-mark-forward] to mark a buffer"))) (let ((count (ibuffer-map-marked-lines (lambda (_buf _mark) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 233127b0112..b461197abe9 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -1257,7 +1257,9 @@ Otherwise, toggle lock status." "Unmark all buffers with mark MARK." (interactive "cRemove marks (RET means all):") (if (= (ibuffer-count-marked-lines t) 0) - (message "No buffers marked; use `m' to mark a buffer") + (message (substitute-command-keys + "No buffers marked; use \\\ +\\[ibuffer-mark-forward] to mark a buffer")) (let ((fn (lambda (_buf mk) (unless (eq mk ?\s) (ibuffer-set-mark-1 ?\s)) t))) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 852ef0f1035..47a44a4a60e 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -520,14 +520,14 @@ Return the last form in BODY." ,@body)) (defun image-dired-dir () - "Return the current thumbnails directory (from variable `image-dired-dir'). -Create the thumbnails directory if it does not exist." + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." (let ((image-dired-dir (file-name-as-directory - (expand-file-name image-dired-dir)))) + (expand-file-name image-dired-dir)))) (unless (file-directory-p image-dired-dir) (with-file-modes #o700 (make-directory image-dired-dir t)) - (message "Creating thumbnails directory")) + (message "Thumbnail directory created: %s" image-dired-dir)) image-dired-dir)) (defun image-dired-insert-image (file type relief margin) @@ -743,9 +743,9 @@ and remove the cached thumbnail files between each trial run.") (thumbnail-dir (file-name-directory thumbnail-file)) process) (when (not (file-exists-p thumbnail-dir)) - (message "Creating thumbnail directory") (with-file-modes #o700 - (make-directory thumbnail-dir t))) + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) ;; Thumbnail file creation processes begin here and are marshaled ;; in a queue by `image-dired-create-thumb'. @@ -2013,7 +2013,7 @@ With prefix argument ARG, display image in its original size." (cons ?o (expand-file-name file)) (cons ?t image-dired-temp-rotate-image-file)))) (unless (eq 'jpeg (image-type file)) - (error "Only JPEG images can be rotated!")) + (user-error "Only JPEG images can be rotated")) (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program nil nil nil (mapcar (lambda (arg) (format-spec arg spec)) diff --git a/lisp/indent.el b/lisp/indent.el index aa6b8d17c4a..ec01733d123 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -88,16 +88,20 @@ This variable has no effect unless `tab-always-indent' is `complete'." indent-relative-first-indent-point) "Values that are ignored by `indent-according-to-mode'.") -(defun indent-according-to-mode () +(defun indent-according-to-mode (&optional inhibit-widen) "Indent line in proper way for current major mode. Normally, this is done by calling the function specified by the variable `indent-line-function'. However, if the value of that variable is present in the `indent-line-ignored-functions' variable, handle it specially (since those functions are used for tabbing); -in that case, indent by aligning to the previous non-blank line." +in that case, indent by aligning to the previous non-blank line. + +Ignore restriction, unless the optional argument INHIBIT-WIDEN is +non-nil." (interactive) (save-restriction - (widen) + (unless inhibit-widen + (widen)) (syntax-propertize (line-end-position)) (if (memq indent-line-function indent-line-ignored-functions) ;; These functions are used for tabbing, but can't be used for @@ -601,7 +605,10 @@ column to indent to; if it is nil, use one of the three methods above." (funcall indent-region-function start end))) ;; Else, use a default implementation that calls indent-line-function on ;; each line. - (t (indent-region-line-by-line start end))) + (t + (save-restriction + (widen) + (indent-region-line-by-line start end)))) ;; In most cases, reindenting modifies the buffer, but it may also ;; leave it unmodified, in which case we have to deactivate the mark ;; by hand. @@ -615,7 +622,7 @@ column to indent to; if it is nil, use one of the three methods above." (make-progress-reporter "Indenting region..." (point) end)))) (while (< (point) end) (or (and (bolp) (eolp)) - (indent-according-to-mode)) + (indent-according-to-mode t)) (forward-line 1) (and pr (progress-reporter-update pr (point)))) (and pr (progress-reporter-done pr)) diff --git a/lisp/info.el b/lisp/info.el index cd4c867f4e6..94537c2417a 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4896,9 +4896,16 @@ first line or header line, and for breadcrumb links.") ;; an end of sentence (skip-syntax-backward " (")) (setq other-tag - (cond ((save-match-data (looking-back "\\(^\\| \\)see" + (cond ((save-match-data (looking-back "\\(^\\|[ (]\\)see" (- (point) 4))) "") + ;; We want "Also *note" to produce + ;; "Also see", but "See also *note" to produce + ;; "See also", so match case-sensitively. + ((save-match-data (let ((case-fold-search nil)) + (looking-back "\\(^\\| \\)also" + (- (point) 5)))) + "") ((save-match-data (looking-back "\\(^\\| \\)in" (- (point) 3))) "") diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 5aefda23283..3a8e968c34b 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -1594,12 +1594,14 @@ GROUP must be one of these symbols: such as U+200C (ZWNJ), U+200E (LRM), but excluding characters that have graphic images, such as U+00AD (SHY). - `variation-selectors': U+FE00..U+FE0F, used for choosing between - glyph variations (e.g. Emoji vs Text - presentation). - `no-font': characters for which no suitable font is found. - For character terminals, characters that cannot - be encoded by `terminal-coding-system'. + `variation-selectors': + Characters in the range U+FE00..U+FE0F, used for + selecting alternate glyph presentations, such as + Emoji vs Text presentation, of the preceding + character(s). + `no-font': For GUI frames, characters for which no suitable + font is found; for text-mode frames, characters + that cannot be encoded by `terminal-coding-system'. METHOD must be one of these symbols: `zero-width': don't display. @@ -1618,31 +1620,36 @@ function (`update-glyphless-char-display'), which updates :type '(alist :key-type (symbol :tag "Character Group") :value-type (symbol :tag "Display Method")) :options '((c0-control - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (c1-control - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (format-control - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (variation-selectors - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (no-font - (choice (const :tag "Don't display" zero-width) + (choice :value hex-code + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index d2570e99111..5f8c358caab 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -184,10 +184,10 @@ character) under point is." (get-char-code-property (aref glyph 0) 'name))) (defvar-keymap emoji-list-mode-map - ["RET"] #'emoji-list-select - [""] #'emoji-list-select + "RET" #'emoji-list-select + "" #'emoji-list-select "h" #'emoji-list-help - [follow-link] 'mouse-face) + "" 'mouse-face) (define-derived-mode emoji-list-mode special-mode "Emoji" "Mode to display emojis." diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 2b94a2845f7..a4cbf22511c 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -88,7 +88,7 @@ (bindings--define-key map [separator-3] menu-bar-separator) (bindings--define-key map [set-terminal-coding-system] '(menu-item "For Terminal" set-terminal-coding-system - :enable (null (memq initial-window-system '(x w32 ns pgtk))) + :enable (null (memq initial-window-system '(x w32 ns haiku pgtk))) :help "How to encode terminal output")) (bindings--define-key map [set-keyboard-coding-system] '(menu-item "For Keyboard" set-keyboard-coding-system diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 0f8dedfc09b..3da47e701ab 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -536,74 +536,124 @@ COMPOSITION-PREDICATE will be used to compose region." (,ucs-normalize-region (point-min) (point-max)) (buffer-string))) -;;;###autoload (defun ucs-normalize-NFD-region (from to) - "Normalize the current region by the Unicode NFD." + "Decompose the region between FROM and TO according to the Unicode NFD. +This replaces the text between FROM and TO with its canonical decomposition, +a.k.a. the \"Unicode Normalization Form D\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfd-quick-check-regexp 'ucs-normalize-nfd-table nil)) -;;;###autoload + (defun ucs-normalize-NFD-string (str) - "Normalize the string STR by the Unicode NFD." + "Decompose the string STR according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STR, +a.k.a. the \"Unicode Normalization Form D\" of STR. For instance: + + (ucs-normalize-NFD-string \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFD-region)) -;;;###autoload (defun ucs-normalize-NFC-region (from to) - "Normalize the current region by the Unicode NFC." + "Compose the region between FROM and TO according to the Unicode NFC. +This replaces the text between FROM and TO with the result of its +canonical decomposition (see `ucs-normalize-NFD-region') followed by +canonical composition, a.k.a. the \"Unicode Normalization Form C\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfc-quick-check-regexp 'ucs-normalize-nfd-table t)) -;;;###autoload -(defun ucs-normalize-NFC-string (str) - "Normalize the string STR by the Unicode NFC." - (ucs-normalize-string ucs-normalize-NFC-region)) ;;;###autoload +(defun string-glyph-compose (string) + "Compose STRING according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STRING (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STRING. +For instance: + + (string-glyph-compose \"Å\") => \"Å\"" + (ucs-normalize-NFC-string string)) + +;;;###autoload +(defun string-glyph-decompose (string) + "Decompose STRING according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STRING, +a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance: + + (ucs-normalize-NFD-string \"Å\") => \"Å\"" + (ucs-normalize-NFD-string string)) + +(defun ucs-normalize-NFC-string (str) + "Compose STR according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STR (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STR. +For instance: + + (string-glyph-compose \"Å\") => \"Å\"" + (ucs-normalize-string ucs-normalize-NFC-region)) + (defun ucs-normalize-NFKD-region (from to) - "Normalize the current region by the Unicode NFKD." + "Decompose the region between FROM and TO according to the Unicode NFKD. +This replaces the text between FROM and TO with its compatibility +decomposition, a.k.a. \"Unicode Normalization Form KD\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkd-quick-check-regexp 'ucs-normalize-nfkd-table nil)) -;;;###autoload + (defun ucs-normalize-NFKD-string (str) - "Normalize the string STR by the Unicode NFKD." + "Decompose the string STR according to the Unicode NFKD. +This returns a new string obtained by compatibility decomposition +of STR. This is much like the NFD (canonical decomposition) form, +see `ucs-normalize-NFD-string', but mainly differs for precomposed +characters. For instance: + + (ucs-normalize-NFD-string \"fi\") => \"fi\" + (ucs-normalize-NFKD-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKD-region)) -;;;###autoload (defun ucs-normalize-NFKC-region (from to) - "Normalize the current region by the Unicode NFKC." + "Compose the region between FROM and TO according to the Unicode NFKC. +This replaces the text between FROM and TO with the result of its +compatibility decomposition (see `ucs-normalize-NFC-region') followed by +canonical composition, a.k.a. the \"Unicode Normalization Form KC\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkc-quick-check-regexp 'ucs-normalize-nfkd-table t)) -;;;###autoload + (defun ucs-normalize-NFKC-string (str) - "Normalize the string STR by the Unicode NFKC." + "Compose STR according to the Unicode NFC. +This returns a new string obtained by compatibility decomposition +of STR (see `ucs-normalize-NFKD-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form KC\" of STR. +This is much like the NFC (canonical composition) form, but mainly +differs for precomposed characters. For instance: + + (ucs-normalize-NFC-string \"fi\") => \"fi\" + (ucs-normalize-NFKC-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKC-region)) -;;;###autoload (defun ucs-normalize-HFS-NFD-region (from to) - "Normalize the current region by the Unicode NFD and Mac OS's HFS Plus." + "Normalize region between FROM and TO by Unicode NFD and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfd-quick-check-regexp 'ucs-normalize-hfs-nfd-table 'ucs-normalize-hfs-nfd-comp-p)) -;;;###autoload + (defun ucs-normalize-HFS-NFD-string (str) "Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus." (ucs-normalize-string ucs-normalize-HFS-NFD-region)) -;;;###autoload + (defun ucs-normalize-HFS-NFC-region (from to) - "Normalize the current region by the Unicode NFC and Mac OS's HFS Plus." + "Normalize region between FROM and TO by Unicode NFC and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfc-quick-check-regexp 'ucs-normalize-hfs-nfd-table t)) -;;;###autoload + (defun ucs-normalize-HFS-NFC-string (str) "Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus." (ucs-normalize-string ucs-normalize-HFS-NFC-region)) diff --git a/lisp/isearch.el b/lisp/isearch.el index dea96624774..9dc8525417a 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -488,9 +488,9 @@ and doesn't remove full-buffer highlighting after a search." "You have typed %THIS-KEY%, the help character. Type a Help option: \(Type \\\\[help-quit] to exit the Help command.) -\\[isearch-describe-bindings] Display all Isearch key bindings. -\\[isearch-describe-key] KEYS Display full documentation of Isearch key sequence. -\\[isearch-describe-mode] Display documentation of Isearch mode. + \\[isearch-describe-bindings] Display all Isearch key bindings. + \\[isearch-describe-key] Display full documentation of Isearch key sequence. + \\[isearch-describe-mode] Display documentation of Isearch mode. You can't type here other help keys available in the global help map, but outside of this help window when you type them in Isearch mode, diff --git a/lisp/keymap.el b/lisp/keymap.el new file mode 100644 index 00000000000..770a6ed20d1 --- /dev/null +++ b/lisp/keymap.el @@ -0,0 +1,457 @@ +;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This library deals with the "new" keymap binding interface: The +;; only key syntax allowed by these functions is the `kbd' one. + +;;; Code: + + + +(defun keymap--check (key) + "Signal an error if KEY doesn't have a valid syntax." + (unless (key-valid-p key) + (error "%S is not a valid key definition; see `key-valid-p'" key))) + +(defun keymap--compile-check (&rest keys) + (dolist (key keys) + (when (or (vectorp key) + (and (stringp key) (not (key-valid-p key)))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) + +(defun keymap-set (keymap key definition) + "Set key sequence KEY to DEFINITION in KEYMAP. +KEY is a string that satisfies `key-valid-p'. + +DEFINITION is anything that can be a key's definition: + nil (means key is undefined in this keymap), + a command (a Lisp function suitable for interactive calling), + a string (treated as a keyboard macro), + a keymap (to define a prefix key), + a symbol (when the key is looked up, the symbol will stand for its + function definition, which should at that time be one of the above, + or another symbol whose function definition is used, etc.), + a cons (STRING . DEFN), meaning that DEFN is the definition + (DEFN should be a valid definition in its own right) and + STRING is the menu item name (which is used only if the containing + keymap has been created with a menu name, see `make-keymap'), + or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, + or an extended menu item definition. + (See info node `(elisp)Extended Menu Items'.)" + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (define-key keymap (key-parse key) definition)) + +(defun keymap-global-set (key command) + "Give KEY a global binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. + +KEY is a string that satisfies `key-valid-p'. + +Note that if KEY has a local binding in the current buffer, +that local binding will continue to shadow any global binding +that you make with this function." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive + (let* ((menu-prompting nil) + (key (read-key-sequence "Set key globally: " nil t))) + (list key + (read-command (format "Set key %s to command: " + (key-description key)))))) + (keymap-set (current-global-map) key command)) + +(defun keymap-local-set (key command) + "Give KEY a local binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. + +KEY is a string that satisfies `key-valid-p'. + +The binding goes in the current buffer's local map, which in most +cases is shared with all other buffers in the same major mode." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive "KSet key locally: \nCSet key %s locally to command: ") + (let ((map (current-local-map))) + (unless map + (use-local-map (setq map (make-sparse-keymap)))) + (keymap-set map key command))) + +(defun keymap-global-unset (key &optional remove) + "Remove global binding of KEY (if any). +KEY is a string that satisfies `key-valid-p'. + +If REMOVE (interactively, the prefix arg), remove the binding +instead of unsetting it. See `keymap-unset' for details." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive + (list (key-description (read-key-sequence "Set key locally: ")) + current-prefix-arg)) + (keymap-unset (current-global-map) key remove)) + +(defun keymap-local-unset (key &optional remove) + "Remove local binding of KEY (if any). +KEY is a string that satisfies `key-valid-p'. + +If REMOVE (interactively, the prefix arg), remove the binding +instead of unsetting it. See `keymap-unset' for details." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive + (list (key-description (read-key-sequence "Unset key locally: ")) + current-prefix-arg)) + (when (current-local-map) + (keymap-unset (current-local-map) key remove))) + +(defun keymap-unset (keymap key &optional remove) + "Remove key sequence KEY from KEYMAP. +KEY is a string that satisfies `key-valid-p'. + +If REMOVE, remove the binding instead of unsetting it. This only +makes a difference when there's a parent keymap. When unsetting +a key in a child map, it will still shadow the same key in the +parent keymap. Removing the binding will allow the key in the +parent keymap to be used." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (define-key keymap (key-parse key) nil remove)) + +(defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) + "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +In other words, OLDDEF is replaced with NEWDEF wherever it appears. +Alternatively, if optional fourth argument OLDMAP is specified, we redefine +in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. + +If you don't specify OLDMAP, you can usually get the same results +in a cleaner way with command remapping, like this: + (define-key KEYMAP [remap OLDDEF] NEWDEF) +\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" + (declare (compiler-macro + (lambda (form) (keymap--compile-check olddef newdef) form))) + ;; Don't document PREFIX in the doc string because we don't want to + ;; advertise it. It's meant for recursive calls only. Here's its + ;; meaning + + ;; If optional argument PREFIX is specified, it should be a key + ;; prefix, a string. Redefined bindings will then be bound to the + ;; original key, with PREFIX added at the front. + (unless prefix + (setq prefix "")) + (keymap--check olddef) + (keymap--check newdef) + (setq olddef (key-parse olddef)) + (setq newdef (key-parse newdef)) + (let* ((scan (or oldmap keymap)) + (prefix1 (vconcat prefix [nil])) + (key-substitution-in-progress + (cons scan key-substitution-in-progress))) + ;; Scan OLDMAP, finding each char or event-symbol that + ;; has any definition, and act on it with hack-key. + (map-keymap + (lambda (char defn) + (aset prefix1 (length prefix) char) + (substitute-key-definition-key defn olddef newdef prefix1 keymap)) + scan))) + +(defun keymap-set-after (keymap key definition &optional after) + "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is like `keymap-set' except that the binding for KEY is placed +just after the binding for the event AFTER, instead of at the beginning +of the map. Note that AFTER must be an event type (like KEY), NOT a command +\(like DEFINITION). + +If AFTER is t or omitted, the new binding goes at the end of the keymap. +AFTER should be a single event type--a symbol or a character, not a sequence. + +Bindings are always added before any inherited map. + +The order of bindings in a keymap matters only when it is used as +a menu, so this function is not useful for non-menu keymaps." + (declare (indent defun) + (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (when after + (keymap--check after)) + (define-key-after keymap (key-parse key) definition + (and after (key-parse after)))) + +(defun key-parse (keys) + "Convert KEYS to the internal Emacs key representation. +See `kbd' for a descripion of KEYS." + (declare (pure t) (side-effect-free t)) + ;; A pure function is expected to preserve the match data. + (save-match-data + (let ((case-fold-search nil) + (len (length keys)) ; We won't alter keys in the loop below. + (pos 0) + (res [])) + (while (and (< pos len) + (string-match "[^ \t\n\f]+" keys pos)) + (let* ((word-beg (match-beginning 0)) + (word-end (match-end 0)) + (word (substring keys word-beg len)) + (times 1) + key) + ;; Try to catch events of the form "". + (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) + (setq word (match-string 0 word) + pos (+ word-beg (match-end 0))) + (setq word (substring keys word-beg word-end) + pos word-end)) + (when (string-match "\\([0-9]+\\)\\*." word) + (setq times (string-to-number (substring word 0 (match-end 1)))) + (setq word (substring word (1+ (match-end 1))))) + (cond ((string-match "^<<.+>>$" word) + (setq key (vconcat (if (eq (key-binding [?\M-x]) + 'execute-extended-command) + [?\M-x] + (or (car (where-is-internal + 'execute-extended-command)) + [?\M-x])) + (substring word 2 -2) "\r"))) + ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) + (progn + (setq word (concat (match-string 1 word) + (match-string 3 word))) + (not (string-match + "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" + word)))) + (setq key (list (intern word)))) + ((or (equal word "REM") (string-match "^;;" word)) + (setq pos (string-match "$" keys pos))) + (t + (let ((orig-word word) (prefix 0) (bits 0)) + (while (string-match "^[ACHMsS]-." word) + (setq bits (+ bits + (cdr + (assq (aref word 0) + '((?A . ?\A-\^@) (?C . ?\C-\^@) + (?H . ?\H-\^@) (?M . ?\M-\^@) + (?s . ?\s-\^@) (?S . ?\S-\^@)))))) + (setq prefix (+ prefix 2)) + (setq word (substring word 2))) + (when (string-match "^\\^.$" word) + (setq bits (+ bits ?\C-\^@)) + (setq prefix (1+ prefix)) + (setq word (substring word 1))) + (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") + ("LFD" . "\n") ("TAB" . "\t") + ("ESC" . "\e") ("SPC" . " ") + ("DEL" . "\177"))))) + (when found (setq word (cdr found)))) + (when (string-match "^\\\\[0-7]+$" word) + (let ((n 0)) + (dolist (ch (cdr (string-to-list word))) + (setq n (+ (* n 8) ch -48))) + (setq word (vector n)))) + (cond ((= bits 0) + (setq key word)) + ((and (= bits ?\M-\^@) (stringp word) + (string-match "^-?[0-9]+$" word)) + (setq key (mapcar (lambda (x) (+ x bits)) + (append word nil)))) + ((/= (length word) 1) + (error "%s must prefix a single character, not %s" + (substring orig-word 0 prefix) word)) + ((and (/= (logand bits ?\C-\^@) 0) (stringp word) + ;; We used to accept . and ? here, + ;; but . is simply wrong, + ;; and C-? is not used (we use DEL instead). + (string-match "[@-_a-z]" word)) + (setq key (list (+ bits (- ?\C-\^@) + (logand (aref word 0) 31))))) + (t + (setq key (list (+ bits (aref word 0))))))))) + (when key + (dolist (_ (number-sequence 1 times)) + (setq res (vconcat res key)))))) + (if (and (>= (length res) 4) + (eq (aref res 0) ?\C-x) + (eq (aref res 1) ?\() + (eq (aref res (- (length res) 2)) ?\C-x) + (eq (aref res (- (length res) 1)) ?\))) + (apply #'vector (let ((lres (append res nil))) + ;; Remove the first and last two elements. + (setq lres (cdr (cdr lres))) + (nreverse lres) + (setq lres (cdr (cdr lres))) + (nreverse lres))) + res)))) + +(defun key-valid-p (keys) + "Say whether KEYS is a valid `kbd' sequence. +A `kbd' sequence is a string consisting of one and more key +strokes. The key strokes are separated by a space character. + +Each key stroke is either a single character, or the name of an +event, surrounded by angle brackets. In addition, any key stroke +may be preceded by one or more modifier keys. Finally, a limited +number of characters have a special shorthand syntax. + +Here's some example key sequences. + + \"f\" (the key 'f') + \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') + \"C-c o\" (a two key sequence of the keys 'c' with the control modifier + and then the key 'o') + \"H-\" (the key named \"left\" with the hyper modifier) + \"M-RET\" (the \"return\" key with a meta modifier) + \"C-M-\" (the \"space\" key with both the control and meta modifiers) + +These are the characters that have shorthand syntax: +NUL, RET, TAB, LFD, ESC, SPC, DEL. + +Modifiers have to be specified in this order: + + A-C-H-M-S-s + +which is + + Alt-Control-Hyper-Meta-Shift-super" + (declare (pure t) (side-effect-free t)) + (and + (stringp keys) + (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) + (save-match-data + (catch 'exit + (let ((prefixes + "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") + (case-fold-search nil)) + (dolist (key (split-string keys " ")) + ;; Every key might have these modifiers, and they should be + ;; in this order. + (when (string-match (concat "\\`" prefixes) key) + (setq key (substring key (match-end 0)))) + (unless (or (and (= (length key) 1) + ;; Don't accept control characters as keys. + (not (< (aref key 0) ?\s)) + ;; Don't accept Meta'd characters as keys. + (or (multibyte-string-p key) + (not (<= 127 (aref key 0) 255)))) + (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) + ;; Don't allow . + (= (progn + (string-match + (concat "\\`<" prefixes) key) + (match-end 0)) + 1)) + (string-match-p + "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" + key)) + ;; Invalid. + (throw 'exit nil))) + t))))) + +(defun key-translate (from to) + "Translate character FROM to TO on the current terminal. +This function creates a `keyboard-translate-table' if necessary +and then modifies one entry in it. + +Both KEY and TO are strings that satisfy `key-valid-p'." + (declare (compiler-macro + (lambda (form) (keymap--compile-check from to) form))) + (keymap--check from) + (keymap--check to) + (or (char-table-p keyboard-translate-table) + (setq keyboard-translate-table + (make-char-table 'keyboard-translate-table nil))) + (aset keyboard-translate-table (key-parse from) (key-parse to))) + +(defun keymap-lookup (keymap key &optional accept-default no-remap position) + "Return the binding for command KEY. +KEY is a string that satisfies `key-valid-p'. + +If KEYMAP is nil, look up in the current keymaps. If non-nil, it +should either be a keymap or a list of keymaps, and only these +keymap(s) will be consulted. + +The binding is probably a symbol with a function definition. + +Normally, `keymap-lookup' ignores bindings for t, which act as +default bindings, used when nothing else in the keymap applies; +this makes it usable as a general function for probing keymaps. +However, if the optional second argument ACCEPT-DEFAULT is +non-nil, `keymap-lookup' does recognize the default bindings, +just as `read-key-sequence' does. + +Like the normal command loop, `keymap-lookup' will remap the +command resulting from looking up KEY by looking up the command +in the current keymaps. However, if the optional third argument +NO-REMAP is non-nil, `keymap-lookup' returns the unmapped +command. + +If KEY is a key sequence initiated with the mouse, the used keymaps +will depend on the clicked mouse position with regard to the buffer +and possible local keymaps on strings. + +If the optional argument POSITION is non-nil, it specifies a mouse +position as returned by `event-start' and `event-end', and the lookup +occurs in the keymaps associated with it instead of KEY. It can also +be a number or marker, in which case the keymap properties at the +specified buffer position instead of point are used." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (when (and keymap (not position)) + (error "Can't pass in both keymap and position")) + (if keymap + (let ((value (lookup-key (key-parse key) keymap accept-default))) + (when (and (not no-remap) + (symbolp value)) + (or (command-remapping value) value))) + (key-binding (kbd key) accept-default no-remap position))) + +(defun keymap-local-lookup (keys &optional accept-default) + "Return the binding for command KEYS in current local keymap only. +KEY is a string that satisfies `key-valid-p'. + +The binding is probably a symbol with a function definition. + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `keymap-lookup' for more details +about this." + (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) + (when-let ((map (current-local-map))) + (keymap-lookup map keys accept-default))) + +(defun keymap-global-lookup (keys &optional accept-default message) + "Return the binding for command KEYS in current global keymap only. +KEY is a string that satisfies `key-valid-p'. + +The binding is probably a symbol with a function definition. +This function's return values are the same as those of `keymap-lookup' +\(which see). + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `keymap-lookup' for more details +about this. + +If MESSAGE (and interactively), message the result." + (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) + (interactive + (list (key-description (read-key-sequence "Look up key in global keymap: ")) + nil t)) + (let ((def (keymap-lookup (current-global-map) keys accept-default))) + (when message + (message "%s is bound to %s globally" keys def)) + def)) + +(provide 'keymap) + +;;; keymap.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 2eae134e3d1..613d9734ae5 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1,4 +1,5 @@ ;;; loaddefs.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; This file will be copied to ldefs-boot.el and checked in periodically. ;; ;;; Code: @@ -2381,12 +2382,7 @@ a reflection. (define-key ctl-x-r-map "M" 'bookmark-set-no-overwrite) (define-key ctl-x-r-map "l" 'bookmark-bmenu-list) -(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "D" 'bookmark-delete-all) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\ -Keymap containing bindings to bookmark functions. -It is not bound to any key by default: to bind it -so that you have a bookmark prefix, just use `global-set-key' and bind a -key of your choice to variable `bookmark-map'. All interactive bookmark -functions have a binding in this keymap.") +(defvar-keymap bookmark-map :doc "Keymap containing bindings to bookmark functions.\nIt is not bound to any key by default: to bind it\nso that you have a bookmark prefix, just use `global-set-key' and bind a\nkey of your choice to variable `bookmark-map'. All interactive bookmark\nfunctions have a binding in this keymap." "x" #'bookmark-set "m" #'bookmark-set "M" #'bookmark-set-no-overwrite "j" #'bookmark-jump "g" #'bookmark-jump "o" #'bookmark-jump-other-window "5" #'bookmark-jump-other-frame "i" #'bookmark-insert "e" #'edit-bookmarks "f" #'bookmark-insert-location "r" #'bookmark-rename "d" #'bookmark-delete "D" #'bookmark-delete-all "l" #'bookmark-load "w" #'bookmark-write "s" #'bookmark-save) (fset 'bookmark-map bookmark-map) (autoload 'bookmark-set "bookmark" "\ @@ -4772,6 +4768,14 @@ space at the end of each line. \(fn &optional NO-ERROR)" t nil) +(autoload 'checkdoc-dired "checkdoc" "\ +In Dired, run `checkdoc' on marked files. +Skip anything that doesn't have the Emacs Lisp library file +extension (\".el\"). +When called from Lisp, FILES is a list of filenames. + +\(fn FILES)" '(dired-mode) nil) + (autoload 'checkdoc-ispell "checkdoc" "\ Check the style and spelling of everything interactively. Calls `checkdoc' with spell-checking turned on. @@ -6755,7 +6759,7 @@ You can set this option through Custom, if you carefully read the last paragraph below. However, usually it is simpler to write something like the following in your init file: -\(setq custom-file \"~/.emacs-custom.el\") +\(setq custom-file \"~/.config/emacs-custom.el\") \(load custom-file) Note that both lines are necessary: the first line tells Custom to @@ -11135,6 +11139,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t) (function-put 'ert-deftest 'doc-string-elt '3) @@ -11167,11 +11174,8 @@ the tests). Run the tests specified by SELECTOR and display the results in a buffer. SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message. -\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil) +\(fn SELECTOR)" t nil) (defalias 'ert #'ert-run-tests-interactively) @@ -13301,7 +13305,7 @@ retrieval with `flymake-diagnostic-data'. If LOCUS is a buffer BEG and END should be buffer positions inside it. If LOCUS designates a file, BEG and END should be a cons (LINE . COL) indicating a file position. In this second -case, END may be ommited in which case the region is computed +case, END may be omitted in which case the region is computed using `flymake-diag-region' if the diagnostic is appended to an actual buffer. @@ -30412,6 +30416,29 @@ only these files will be asked to be saved. \(fn ARG)" nil nil) +(autoload 'server-stop-automatically "server" "\ +Automatically stop server as specified by ARG. + +If ARG is the symbol `empty', stop the server when it has no +remaining clients, no remaining unsaved file-visiting buffers, +and no running processes with a `query-on-exit' flag. + +If ARG is the symbol `delete-frame', ask the user when the last +frame is deleted whether each unsaved file-visiting buffer must +be saved and each running process with a `query-on-exit' flag +can be stopped, and if so, stop the server itself. + +If ARG is the symbol `kill-terminal', ask the user when the +terminal is killed with \\[save-buffers-kill-terminal] whether each unsaved file-visiting +buffer must be saved and each running process with a `query-on-exit' +flag can be stopped, and if so, stop the server itself. + +Any other value of ARG will cause this function to signal an error. + +This function is meant to be called from the user init file. + +\(fn ARG)" nil nil) + (register-definition-prefixes "server" '("server-")) ;;;*** @@ -30748,7 +30775,7 @@ If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). \(fn GROUP &optional FUNCTION)" t nil) -(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector")) +(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "keymaps" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector")) ;;;*** @@ -35146,7 +35173,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;;;; 0)) ;;; Generated autoloads from net/tramp-compat.el -(register-definition-prefixes "tramp-compat" '("tramp-")) +(register-definition-prefixes "tramp-compat" '("tramp-compat-")) ;;;*** @@ -35232,7 +35259,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 5 2 -1)) package--builtin-versions) +(push (purecopy '(tramp 2 6 0 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) @@ -35555,65 +35582,21 @@ You might need to set `uce-mail-reader' before using this. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from international/ucs-normalize.el -(autoload 'ucs-normalize-NFD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFD. +(autoload 'string-glyph-compose "ucs-normalize" "\ +Compose the string STR by according to the Unicode NFC. +This is the canonical composed form. For instance: -\(fn FROM TO)" t nil) + (ucs-normalize-NFC-string \"Å\") => \"Å\" -(autoload 'ucs-normalize-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD. +\(fn STRING)" nil nil) -\(fn STR)" nil nil) +(autoload 'string-glyph-decompose "ucs-normalize" "\ +Decompose the string STR according to the Unicode NFD. +This is the canonical decomposed form. For instance: -(autoload 'ucs-normalize-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC. + (ucs-normalize-NFD-string \"Å\") => \"Å\" -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFKD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFKD. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFKD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFKD. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFKC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFKC. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFKC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFKC. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-HFS-NFD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFD and Mac OS's HFS Plus. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-HFS-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-HFS-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC and Mac OS's HFS Plus. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-HFS-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus. - -\(fn STR)" nil nil) +\(fn STRING)" nil nil) (register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs")) @@ -39738,7 +39721,7 @@ Zone out, completely." t nil) ;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" ;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" ;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" -;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" +;;;;;; "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" "language/cham.el" ;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" ;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" ;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" diff --git a/lisp/loadup.el b/lisp/loadup.el index c6bd930cdf7..3d941f7b512 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -131,6 +131,7 @@ (load "emacs-lisp/byte-run") (load "emacs-lisp/backquote") (load "subr") +(load "keymap") ;; Do it after subr, since both after-load-functions and add-hook are ;; implemented in subr.el. @@ -302,6 +303,11 @@ (load "term/common-win") (load "term/x-win"))) +(if (featurep 'haiku) + (progn + (load "term/common-win") + (load "term/haiku-win"))) + (if (or (eq system-type 'windows-nt) (featurep 'w32)) (progn @@ -564,6 +570,7 @@ lost after dumping"))) (delete-file output))))) ;; Recompute NAME now, so that it isn't set when we dump. (if (not (or (eq system-type 'ms-dos) + (eq system-type 'haiku) ;; BFS doesn't support hard links ;; Don't bother adding another name if we're just ;; building bootstrap-emacs. (member dump-mode '("pbootstrap" "bootstrap")))) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 716348a9c19..ef040ca90b3 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -898,7 +898,7 @@ play around with the following keys: (make-local-variable 'footnote-end-tag) (make-local-variable 'adaptive-fill-function) - ;; Filladapt was an XEmacs package which is now in GNU ELPA. + ;; Filladapt is a GNU ELPA package. (when (boundp 'filladapt-token-table) ;; add tokens to filladapt to match footnotes ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index f393ac773f5..b3080ac416b 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -1767,7 +1767,7 @@ is determined non-interactively. The value is queried for in the minibuffer exactly the same way that `set-variable' does it. You can see the current value of the variable when the minibuffer is -querying you by typing `C-h'. Note that the format is changed +querying you by typing \\`C-h'. Note that the format is changed slightly from that used by `set-variable' -- the current value is printed just after the variable's name instead of at the bottom of the help window." diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index b9ca57f5c49..bd110226618 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1347,14 +1347,13 @@ mail status in mode line")) (frame-parameter (menu-bar-frame-for-menubar) 'menu-bar-lines))))) - (unless (featurep 'ns) - (bindings--define-key menu [showhide-tab-bar] - '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame - :help "Turn tab bar on/off" - :button - (:toggle . (menu-bar-positive-p - (frame-parameter (menu-bar-frame-for-menubar) - 'tab-bar-lines)))))) + (bindings--define-key menu [showhide-tab-bar] + '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame + :help "Turn tab bar on/off" + :button + (:toggle . (menu-bar-positive-p + (frame-parameter (menu-bar-frame-for-menubar) + 'tab-bar-lines))))) (if (and (boundp 'menu-bar-showhide-tool-bar-menu) (keymapp menu-bar-showhide-tool-bar-menu)) @@ -2541,6 +2540,7 @@ See `menu-bar-mode' for more information." (declare-function x-menu-bar-open "term/x-win" (&optional frame)) (declare-function w32-menu-bar-open "term/w32-win" (&optional frame)) (declare-function pgtk-menu-bar-open "term/pgtk-win" (&optional frame)) +(declare-function haiku-menu-bar-open "haikumenu.c" (&optional frame)) (defun lookup-key-ignore-too-long (map key) "Call `lookup-key' and convert numeric values to nil." @@ -2666,9 +2666,10 @@ first TTY menu-bar menu to be dropped down. Interactively, this is the numeric argument to the command. This function decides which method to use to access the menu depending on FRAME's terminal device. On X displays, it calls -`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it -calls either `popup-menu' or `tmm-menubar' depending on whether -`tty-menu-open-use-tmm' is nil or not. +`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; on Haiku, +`haiku-menu-bar-open'; otherwise it calls either `popup-menu' +or `tmm-menubar' depending on whether `tty-menu-open-use-tmm' +is nil or not. If FRAME is nil or not given, use the selected frame." (interactive @@ -2677,6 +2678,8 @@ If FRAME is nil or not given, use the selected frame." (cond ((eq type 'x) (x-menu-bar-open frame)) ((eq type 'w32) (w32-menu-bar-open frame)) + ((eq type 'haiku) (haiku-menu-bar-open frame)) + ((eq type 'pgtk) (pgtk-menu-bar-open frame)) ((and (null tty-menu-open-use-tmm) (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0)))) ;; Make sure the menu bar is up to date. One situation where @@ -2739,7 +2742,7 @@ could provide `global-map' where items are limited to the global map only." ;; sorting. (push (cons pos menu-item) menu-end) (push menu-item menu-bar)))) - (lookup-key (or keymap (menu-bar-current-active-maps)) [menu-bar])) + (or keymap (lookup-key (menu-bar-current-active-maps) [menu-bar]))) `(keymap ,@(nreverse menu-bar) ,@(mapcar #'cdr (sort menu-end (lambda (a b) diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index 0669f5bb22c..25fff6a8e1b 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -59,7 +59,8 @@ ;;;###mh-autoload (defmacro mh-funcall-if-exists (function &rest args) "Call FUNCTION with ARGS as parameters if it exists." - (declare (debug (symbolp body))) + (declare (obsolete "use `(when (fboundp 'foo) (foo))' instead." "29.1") + (debug (symbolp body))) ;; FIXME: Not clear when this should be used. If the function happens ;; not to exist at compile-time (e.g. because the corresponding package ;; wasn't loaded), then it won't ever be used :-( diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 5761df5297c..8087df97c94 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -258,15 +258,7 @@ Blind aliases or users from /etc/passwd are not expanded." (read-string prompt) (let* ((minibuffer-local-completion-map mh-alias-read-address-map) (completion-ignore-case mh-alias-completion-ignore-case-flag) - (the-answer - (cond ((fboundp 'completing-read-multiple) - (mh-funcall-if-exists - completing-read-multiple prompt mh-alias-alist nil nil)) - ((featurep 'multi-prompt) - (mh-funcall-if-exists - multi-prompt "," nil prompt mh-alias-alist nil nil)) - (t (split-string - (completing-read prompt mh-alias-alist nil nil) ","))))) + (the-answer (completing-read-multiple prompt mh-alias-alist nil nil))) (if (not mh-alias-expand-aliases-flag) (mapconcat #'identity the-answer ", ") ;; Loop over all elements, checking if in passwd alias or blind first diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index 130d3784ddd..a47a6f9cca9 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -624,6 +624,8 @@ See also `mh-compose-forward-as-mime-flag', (defun mh-forwarded-letter-subject (from subject) "Return a Subject suitable for a forwarded message. Original message has headers FROM and SUBJECT." + ;; Join continued lines. + (setq from (replace-regexp-in-string "\\s *\n\\s +" " " from)) (let ((addr-start (string-search "<" from)) (comment (string-search "(" from))) (cond ((and addr-start (> addr-start 0)) diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index 19be5afd790..23dc48a574c 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -46,10 +46,9 @@ ;; cl-letf. This macro is based upon gmm-flet from Gnus. (defmacro mh-flet (bindings &rest body) "Make temporary overriding function definitions. -This is an analogue of a dynamically scoped `let' that operates on -the function cell of FUNCs rather than their value cell. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" +That is, temporarily rebind the functions listed in BINDINGS and then +execute BODY. BINDINGS is a list containing one or more lists of the +form (FUNCNAME ARGLIST BODY...), similar to defun." (declare (indent 1) (debug ((&rest (sexp sexp &rest form)) &rest form))) (if (fboundp 'cl-letf) `(cl-letf ,(mapcar (lambda (binding) @@ -138,7 +137,7 @@ This is taken from RFC 2396.") #'window-full-height-p "29.1") (defmacro mh-write-file-functions () - "Return `write-file-functions'. " + "Return `write-file-functions'." (declare (obsolete nil "29.1")) ''write-file-functions) diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index c700b3348df..132ac33d269 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -212,7 +212,7 @@ annotation.") ;; Save the "b" binding for a future `back'. Maybe? (define-keymap :keymap mh-folder-mode-map - " " #'mh-page-msg + "SPC" #'mh-page-msg "!" #'mh-refile-or-write-again "'" #'mh-toggle-tick "," #'mh-header-display @@ -223,15 +223,15 @@ annotation.") "?" #'mh-help "E" #'mh-extract-rejected-mail "M" #'mh-modify - "\177" #'mh-previous-page - "\C-d" #'mh-delete-msg-no-motion - "\t" #'mh-index-next-folder - [backtab] #'mh-index-previous-folder - "\M-\t" #'mh-index-previous-folder - "\e<" #'mh-first-msg - "\e>" #'mh-last-msg - "\ed" #'mh-redistribute - "\r" #'mh-show + "DEL" #'mh-previous-page + "C-d" #'mh-delete-msg-no-motion + "TAB" #'mh-index-next-folder + "" #'mh-index-previous-folder + "C-M-i" #'mh-index-previous-folder + "ESC <" #'mh-first-msg + "ESC >" #'mh-last-msg + "ESC d" #'mh-redistribute + "RET" #'mh-show "^" #'mh-alt-refile-msg "c" #'mh-copy-msg "d" #'mh-delete-msg @@ -242,10 +242,10 @@ annotation.") "k" #'mh-delete-subject-or-thread "m" #'mh-alt-send "n" #'mh-next-undeleted-msg - "\M-n" #'mh-next-unread-msg + "M-n" #'mh-next-unread-msg "o" #'mh-refile-msg "p" #'mh-previous-undeleted-msg - "\M-p" #'mh-previous-unread-msg + "M-p" #'mh-previous-unread-msg "q" #'mh-quit "r" #'mh-reply "s" #'mh-send @@ -324,9 +324,9 @@ annotation.") "u" #'mh-store-msg) ;uuencode "D" (define-keymap :prefix 'mh-digest-map - " " #'mh-page-digest + "SPC" #'mh-page-digest "?" #'mh-prefix-help - "\177" #'mh-page-digest-backwards + "DEL" #'mh-page-digest-backwards "b" #'mh-burst-digest) "K" (define-keymap :prefix 'mh-mime-map @@ -337,11 +337,11 @@ annotation.") "o" #'mh-folder-save-mime-part "t" #'mh-toggle-mime-buttons "v" #'mh-folder-toggle-mime-part - "\t" #'mh-next-button - [backtab] #'mh-prev-button - "\M-\t" #'mh-prev-button) + "TAB" #'mh-next-button + "" #'mh-prev-button + "C-M-i" #'mh-prev-button) - [mouse-2] #'mh-show-mouse) + "" #'mh-show-mouse) ;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt @@ -631,7 +631,7 @@ perform the operation on all messages in that region. (add-hook 'write-file-functions #'mh-execute-commands nil t) (make-local-variable 'revert-buffer-function) (make-local-variable 'hl-line-mode) ; avoid pollution - (mh-funcall-if-exists hl-line-mode 1) + (hl-line-mode 1) (setq revert-buffer-function #'mh-undo-folder) (add-to-list 'minor-mode-alist '(mh-showing-mode " Show")) (mh-inc-spool-make) diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index 1f7902640a1..ebe94a7af83 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -115,67 +115,67 @@ ;; If this changes, modify mh-letter-mode-help-messages accordingly, above. (define-keymap :keymap mh-letter-mode-map - " " #'mh-letter-complete-or-space + "SPC" #'mh-letter-complete-or-space "," #'mh-letter-confirm-address - "\C-c?" #'mh-help - "\C-c\C-\\" #'mh-fully-kill-draft ;if no C-q - "\C-c\C-^" #'mh-insert-signature ;if no C-s - "\C-c\C-c" #'mh-send-letter - "\C-c\C-d" #'mh-insert-identity - "\C-c\C-e" #'mh-mh-to-mime - "\C-c\C-f\C-a" #'mh-to-field - "\C-c\C-f\C-b" #'mh-to-field - "\C-c\C-f\C-c" #'mh-to-field - "\C-c\C-f\C-d" #'mh-to-field - "\C-c\C-f\C-f" #'mh-to-fcc - "\C-c\C-f\C-l" #'mh-to-field - "\C-c\C-f\C-m" #'mh-to-field - "\C-c\C-f\C-r" #'mh-to-field - "\C-c\C-f\C-s" #'mh-to-field - "\C-c\C-f\C-t" #'mh-to-field - "\C-c\C-fa" #'mh-to-field - "\C-c\C-fb" #'mh-to-field - "\C-c\C-fc" #'mh-to-field - "\C-c\C-fd" #'mh-to-field - "\C-c\C-ff" #'mh-to-fcc - "\C-c\C-fl" #'mh-to-field - "\C-c\C-fm" #'mh-to-field - "\C-c\C-fr" #'mh-to-field - "\C-c\C-fs" #'mh-to-field - "\C-c\C-ft" #'mh-to-field - "\C-c\C-i" #'mh-insert-letter - "\C-c\C-m\C-e" #'mh-mml-secure-message-encrypt - "\C-c\C-m\C-f" #'mh-compose-forward - "\C-c\C-m\C-g" #'mh-mh-compose-anon-ftp - "\C-c\C-m\C-i" #'mh-compose-insertion - "\C-c\C-m\C-m" #'mh-mml-to-mime - "\C-c\C-m\C-n" #'mh-mml-unsecure-message - "\C-c\C-m\C-s" #'mh-mml-secure-message-sign - "\C-c\C-m\C-t" #'mh-mh-compose-external-compressed-tar - "\C-c\C-m\C-u" #'mh-mh-to-mime-undo - "\C-c\C-m\C-x" #'mh-mh-compose-external-type - "\C-c\C-mee" #'mh-mml-secure-message-encrypt - "\C-c\C-mes" #'mh-mml-secure-message-signencrypt - "\C-c\C-mf" #'mh-compose-forward - "\C-c\C-mg" #'mh-mh-compose-anon-ftp - "\C-c\C-mi" #'mh-compose-insertion - "\C-c\C-mm" #'mh-mml-to-mime - "\C-c\C-mn" #'mh-mml-unsecure-message - "\C-c\C-mse" #'mh-mml-secure-message-signencrypt - "\C-c\C-mss" #'mh-mml-secure-message-sign - "\C-c\C-mt" #'mh-mh-compose-external-compressed-tar - "\C-c\C-mu" #'mh-mh-to-mime-undo - "\C-c\C-mx" #'mh-mh-compose-external-type - "\C-c\C-o" #'mh-open-line - "\C-c\C-q" #'mh-fully-kill-draft - "\C-c\C-s" #'mh-insert-signature - "\C-c\C-t" #'mh-letter-toggle-header-field-display - "\C-c\C-w" #'mh-check-whom - "\C-c\C-y" #'mh-yank-cur-msg - "\C-c\M-d" #'mh-insert-auto-fields - "\M-\t" #'completion-at-point - "\t" #'mh-letter-next-header-field-or-indent - [backtab] #'mh-letter-previous-header-field) + "C-c ?" #'mh-help + "C-c C-\\" #'mh-fully-kill-draft ;if no C-q + "C-c C-^" #'mh-insert-signature ;if no C-s + "C-c C-c" #'mh-send-letter + "C-c C-d" #'mh-insert-identity + "C-c C-e" #'mh-mh-to-mime + "C-c C-f C-a" #'mh-to-field + "C-c C-f C-b" #'mh-to-field + "C-c C-f C-c" #'mh-to-field + "C-c C-f C-d" #'mh-to-field + "C-c C-f C-f" #'mh-to-fcc + "C-c C-f C-l" #'mh-to-field + "C-c C-f C-m" #'mh-to-field + "C-c C-f C-r" #'mh-to-field + "C-c C-f C-s" #'mh-to-field + "C-c C-f C-t" #'mh-to-field + "C-c C-f a" #'mh-to-field + "C-c C-f b" #'mh-to-field + "C-c C-f c" #'mh-to-field + "C-c C-f d" #'mh-to-field + "C-c C-f f" #'mh-to-fcc + "C-c C-f l" #'mh-to-field + "C-c C-f m" #'mh-to-field + "C-c C-f r" #'mh-to-field + "C-c C-f s" #'mh-to-field + "C-c C-f t" #'mh-to-field + "C-c C-i" #'mh-insert-letter + "C-c C-m C-e" #'mh-mml-secure-message-encrypt + "C-c C-m C-f" #'mh-compose-forward + "C-c C-m C-g" #'mh-mh-compose-anon-ftp + "C-c C-m TAB" #'mh-compose-insertion + "C-c C-m C-m" #'mh-mml-to-mime + "C-c C-m C-n" #'mh-mml-unsecure-message + "C-c C-m C-s" #'mh-mml-secure-message-sign + "C-c C-m C-t" #'mh-mh-compose-external-compressed-tar + "C-c C-m C-u" #'mh-mh-to-mime-undo + "C-c C-m C-x" #'mh-mh-compose-external-type + "C-c C-m e e" #'mh-mml-secure-message-encrypt + "C-c C-m e s" #'mh-mml-secure-message-signencrypt + "C-c C-m f" #'mh-compose-forward + "C-c C-m g" #'mh-mh-compose-anon-ftp + "C-c C-m i" #'mh-compose-insertion + "C-c C-m m" #'mh-mml-to-mime + "C-c C-m n" #'mh-mml-unsecure-message + "C-c C-m s e" #'mh-mml-secure-message-signencrypt + "C-c C-m s s" #'mh-mml-secure-message-sign + "C-c C-m t" #'mh-mh-compose-external-compressed-tar + "C-c C-m u" #'mh-mh-to-mime-undo + "C-c C-m x" #'mh-mh-compose-external-type + "C-c C-o" #'mh-open-line + "C-c C-q" #'mh-fully-kill-draft + "C-c C-s" #'mh-insert-signature + "C-c C-t" #'mh-letter-toggle-header-field-display + "C-c C-w" #'mh-check-whom + "C-c C-y" #'mh-yank-cur-msg + "C-c M-d" #'mh-insert-auto-fields + "C-M-i" #'completion-at-point + "TAB" #'mh-letter-next-header-field-or-indent + "" #'mh-letter-previous-header-field) ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 0b58d7ba1f4..714bf029bb7 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -39,6 +39,7 @@ ;;; Code: (require 'mh-e) +(require 'mh-acros) (require 'mh-gnus) ;needed because mh-gnus.el not compiled (require 'font-lock) @@ -700,8 +701,7 @@ buttons for alternative parts that are usually suppressed." ;; Delete the button and displayed part (if any) (let ((region (get-text-property point 'mh-region))) (when region - (mh-funcall-if-exists - remove-images (car region) (cdr region))) + (remove-images (car region) (cdr region))) (mm-display-part handle) (when region (delete-region (car region) (cdr region)))) diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el index 5a1a671aee2..9ac251e8b71 100644 --- a/lisp/mh-e/mh-scan.el +++ b/lisp/mh-e/mh-scan.el @@ -327,7 +327,11 @@ Note that columns in Emacs start with 0.") (defvar mh-scan-cmd-note-width 1 "Number of columns consumed by the cmd-note field in `mh-scan-format'. -This column will have one of the values: \" \", \"^\", \"D\", \"B\", \"A\", \"+\", where +This column will have one of the values: + + \" \", \"^\", \"D\", \"B\", \"A\", \"+\" + +where \" \" is the default value, \"^\" is the `mh-note-refiled' character, @@ -509,7 +513,7 @@ with `mh-scan-msg-format-string'." Note that columns in Emacs start with 0. If `mh-scan-format-file' is set to \"Use MH-E scan Format\" this -means that either `mh-scan-format-mh' or `mh-scan-format-nmh' are +means that either `mh-scan-format-mh' or `mh-scan-format-nmh' is in use. This function therefore assumes that the first column is empty (to provide room for the cursor), the following WIDTH columns contain the message number, and the column for notations diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index ef84c5eb283..8012e624f16 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -550,19 +550,19 @@ group of results." ;; If this changes, modify mh-search-mode-help-messages accordingly, below. (define-keymap :keymap mh-search-mode-map - "\C-c?" #'mh-help - "\C-c\C-c" #'mh-index-do-search - "\C-c\C-p" #'mh-pick-do-search - "\C-c\C-f\C-b" #'mh-to-field - "\C-c\C-f\C-c" #'mh-to-field - "\C-c\C-f\C-m" #'mh-to-field - "\C-c\C-f\C-s" #'mh-to-field - "\C-c\C-f\C-t" #'mh-to-field - "\C-c\C-fb" #'mh-to-field - "\C-c\C-fc" #'mh-to-field - "\C-c\C-fm" #'mh-to-field - "\C-c\C-fs" #'mh-to-field - "\C-c\C-ft" #'mh-to-field) + "C-c ?" #'mh-help + "C-c C-c" #'mh-index-do-search + "C-c C-p" #'mh-pick-do-search + "C-c C-f C-b" #'mh-to-field + "C-c C-f C-c" #'mh-to-field + "C-c C-f C-m" #'mh-to-field + "C-c C-f C-s" #'mh-to-field + "C-c C-f C-t" #'mh-to-field + "C-c C-f b" #'mh-to-field + "C-c C-f c" #'mh-to-field + "C-c C-f m" #'mh-to-field + "C-c C-f s" #'mh-to-field + "C-c C-f t" #'mh-to-field) diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 524179648dc..16489bf0172 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -367,7 +367,8 @@ still visible.\n") (setq normal-exit t)) (deactivate-mark) (when (eq major-mode 'mh-folder-mode) - (mh-funcall-if-exists hl-line-highlight)) + (when (fboundp 'hl-line-highlight) + (hl-line-highlight))) (cond ((not normal-exit) (set-window-configuration config)) ,(if dont-return @@ -560,7 +561,7 @@ still visible.\n") ;;; MH-Show Keys (define-keymap :keymap mh-show-mode-map - " " #'mh-show-page-msg + "SPC" #'mh-show-page-msg "!" #'mh-show-refile-or-write-again "'" #'mh-show-toggle-tick "," #'mh-show-header-display @@ -570,12 +571,12 @@ still visible.\n") "?" #'mh-help "E" #'mh-show-extract-rejected-mail "M" #'mh-show-modify - "\177" #'mh-show-previous-page - "\C-d" #'mh-show-delete-msg-no-motion - "\t" #'mh-show-next-button - [backtab] #'mh-show-prev-button - "\M-\t" #'mh-show-prev-button - "\ed" #'mh-show-redistribute + "DEL" #'mh-show-previous-page + "C-d" #'mh-show-delete-msg-no-motion + "TAB" #'mh-show-next-button + "" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button + "ESC d" #'mh-show-redistribute "^" #'mh-show-refile-msg "c" #'mh-show-copy-msg "d" #'mh-show-delete-msg @@ -586,10 +587,10 @@ still visible.\n") "k" #'mh-show-delete-subject-or-thread "m" #'mh-show-send "n" #'mh-show-next-undeleted-msg - "\M-n" #'mh-show-next-unread-msg + "M-n" #'mh-show-next-unread-msg "o" #'mh-show-refile-msg "p" #'mh-show-previous-undeleted-msg - "\M-p" #'mh-show-previous-unread-msg + "M-p" #'mh-show-previous-unread-msg "q" #'mh-show-quit "r" #'mh-show-reply "s" #'mh-show-send @@ -670,8 +671,8 @@ still visible.\n") "D" (define-keymap :prefix 'mh-show-digest-map "?" #'mh-prefix-help - " " #'mh-show-page-digest - "\177" #'mh-show-page-digest-backwards + "SPC" #'mh-show-page-digest + "DEL" #'mh-show-page-digest-backwards "b" #'mh-show-burst-digest) "K" (define-keymap :prefix 'mh-show-mime-map @@ -682,9 +683,9 @@ still visible.\n") "o" #'mh-show-save-mime-part "i" #'mh-show-inline-mime-part "t" #'mh-show-toggle-mime-buttons - "\t" #'mh-show-next-button - [backtab] #'mh-show-prev-button - "\M-\t" #'mh-show-prev-button)) + "TAB" #'mh-show-next-button + "" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button)) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 82b108c8c8d..d9909a034d9 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -86,7 +86,7 @@ (define-keymap :keymap mh-folder-speedbar-key-map "+" #'mh-speed-expand-folder "-" #'mh-speed-contract-folder - "\r" #'mh-speed-view + "RET" #'mh-speed-view "r" #'mh-speed-refresh) (defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) @@ -535,8 +535,8 @@ be handled next." (insert-char char 1 t) (put-text-property (point) (1- (point)) 'invisible nil) ;; make sure we fix the image on the text here. - (mh-funcall-if-exists - speedbar-insert-image-button-maybe (- (point) 2) 3))))) + (when (fboundp 'speedbar-insert-image-button-maybe) + (speedbar-insert-image-button-maybe (- (point) 2) 3)))))) ;;;###mh-autoload (defun mh-speed-add-folder (folder) diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el index 21954da6acd..1be2185ecdf 100644 --- a/lisp/mh-e/mh-thread.el +++ b/lisp/mh-e/mh-thread.el @@ -139,7 +139,7 @@ to the message that started everything." (cond (thread-root-flag (while (mh-thread-immediate-ancestor)) (mh-maybe-show)) - ((equal current-level 1) + ((equal current-level 0) (message "Message has no ancestor")) (t (mh-thread-immediate-ancestor) (mh-maybe-show))))) @@ -242,8 +242,8 @@ sibling." (defun mh-thread-current-indentation-level () "Find the number of spaces by which current message is indented." (save-excursion - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) + (let ((address-start-offset (+ mh-cmd-note + mh-scan-field-from-start-offset)) (level 0)) (beginning-of-line) (forward-char address-start-offset) @@ -275,8 +275,8 @@ at the end." (beginning-of-line) (if (eobp) nil - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) + (let ((address-start-offset (+ mh-cmd-note + mh-scan-field-from-start-offset)) (level (mh-thread-current-indentation-level)) spaces begin) (setq begin (point)) diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el index 0200d232c33..d451ae34d29 100644 --- a/lisp/mh-e/mh-tool-bar.el +++ b/lisp/mh-e/mh-tool-bar.el @@ -182,8 +182,7 @@ where, (add-to-list vector-list `(vector nil ',function t ,full-doc)) (add-to-list setter `(when (member ',name ,list) - (mh-funcall-if-exists - tool-bar-add-item ,icon ',function ',key + (tool-bar-add-item ,icon ',function ',key :help ,doc :enable ',enable-expr))) (add-to-list mbuttons name) (if docs (add-to-list docs doc)))))) diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index feebf6416fe..b75025d6a4d 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -139,8 +139,7 @@ Ignores case when searching for OLD." 0 2 `(display ,(or mh-logo-cache (setq mh-logo-cache - (mh-funcall-if-exists - find-image '(( :type xpm :ascent center + (find-image '(( :type xpm :ascent center :file "mh-logo.xpm" )))))) (car mode-line-buffer-identification)))) @@ -531,7 +530,12 @@ results of the actual folders call. If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added to each of the sub-folder names that may have nested folders within them." - (let* ((folder (mh-normalize-folder-name folder nil nil t)) + ;; In most cases we want to remove a trailing slash. We keep the + ;; slash for "+/", because it refers to folders in the system root + ;; directory, whereas "+" refers to the user's top-level folders. + (let* ((folder (mh-normalize-folder-name folder nil + (string= folder "+/") + t)) (match (gethash folder mh-sub-folders-cache 'no-result)) (sub-folders (cond ((eq match 'no-result) (setf (gethash folder mh-sub-folders-cache) @@ -558,7 +562,6 @@ Expects FOLDER to have already been normalized with (let ((arg-list `(,(expand-file-name "folders" mh-progs) nil (t nil) nil "-noheader" "-norecurse" "-nototal" ,@(if (stringp folder) (list folder) ()))) - (results ()) (current-folder (concat (with-temp-buffer (call-process (expand-file-name "folder" mh-progs) @@ -567,33 +570,48 @@ Expects FOLDER to have already been normalized with "+"))) (with-temp-buffer (apply #'call-process arg-list) - (goto-char (point-min)) - (while (not (and (eolp) (bolp))) - (goto-char (line-end-position)) - (let ((start-pos (line-beginning-position)) - (has-pos (search-backward " has " - (line-beginning-position) t))) - (when (integerp has-pos) - (while (equal (char-after has-pos) ? ) - (cl-decf has-pos)) - (cl-incf has-pos) - (while (equal (char-after start-pos) ? ) - (cl-incf start-pos)) - (let* ((name (buffer-substring start-pos has-pos)) - (first-char (aref name 0)) - (last-char (aref name (1- (length name))))) - (unless (member first-char '(?. ?# ?,)) - (when (and (equal last-char ?+) (equal name current-folder)) - (setq name (substring name 0 (1- (length name))))) - (push - (cons name - (search-forward "(others)" (line-end-position) t)) - results)))) - (forward-line 1)))) + (mh-sub-folders-parse folder current-folder)))) + +(defun mh-sub-folders-parse (folder current-folder) + "Parse the results of \"folders FOLDER\" and return a list of sub-folders. +CURRENT-FOLDER is the result of \"folder -fast\". +FOLDER will be nil or start with '+'; CURRENT-FOLDER will end with '+'. +This function is a testable helper of `mh-sub-folders-actual'." + (let ((results ())) + (goto-char (point-min)) + (while (not (and (eolp) (bolp))) + (goto-char (line-end-position)) + (let ((start-pos (line-beginning-position)) + (has-pos (search-backward " has " + (line-beginning-position) t))) + (when (integerp has-pos) + (while (equal (char-after has-pos) ? ) + (cl-decf has-pos)) + (cl-incf has-pos) + (while (equal (char-after start-pos) ? ) + (cl-incf start-pos)) + (let* ((name (buffer-substring start-pos has-pos)) + (first-char (aref name 0)) + (second-char (and (length> name 1) (aref name 1))) + (last-char (aref name (1- (length name))))) + (unless (member first-char '(?. ?# ?,)) + (when (and (equal last-char ?+) (equal name current-folder)) + (setq name (substring name 0 (1- (length name))))) + ;; nmh outputs double slash in root folder, e.g., "//tmp" + (when (and (equal first-char ?/) (equal second-char ?/)) + (setq name (substring name 1))) + (push + (cons name + (search-forward "(others)" (line-end-position) t)) + results)))) + (forward-line 1))) (setq results (nreverse results)) (when (stringp folder) (setq results (cdr results)) (let ((folder-name-len (length (format "%s/" (substring folder 1))))) + (when (equal "+/" folder) + ;; folder "+/" includes a trailing slash + (cl-decf folder-name-len)) (setq results (mapcar (lambda (f) (cons (substring (car f) folder-name-len) (cdr f))) diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 0c1bcdfefd5..8350f3d0fbb 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -73,8 +73,7 @@ in this order is used." (when (re-search-forward "^from:" (point-max) t) (if (eq type 'url) (mh-x-image-url-display url) - (mh-funcall-if-exists - insert-image (create-image + (insert-image (create-image raw type t :foreground (face-foreground 'mh-show-xface nil t) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 0fea057d1cb..c2a6b01fc8e 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2734,7 +2734,7 @@ not active.") This is only used when the minibuffer area has no active minibuffer. Note that the minibuffer may change to this mode more often than -you might expect. For instance, typing `M-x' may change the +you might expect. For instance, typing \\`M-x' may change the buffer to this mode, then to a different mode, and then back again to this mode upon exit. Code running from `minibuffer-inactive-mode-hook' has to be prepared to run diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el index ecfb359b36f..0cdba6b4d01 100644 --- a/lisp/mouse-drag.el +++ b/lisp/mouse-drag.el @@ -282,6 +282,8 @@ To test this function, evaluate: (setq window-last-row (- (window-height) 2) window-last-col (- (window-width) 2)) (track-mouse + ;; Set 'track-mouse' to something neither nil nor t (Bug#51794). + (setq track-mouse 'drag-dragging) (while (progn (setq event (read--potential-mouse-event) end (event-end event) diff --git a/lisp/mouse.el b/lisp/mouse.el index 4f9c49ce463..3ab9fbcdfe2 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -364,7 +364,7 @@ Some context functions add menu items below the separator." (when (consp binding) (define-key-after menu (vector key) (copy-sequence binding)))) - (menu-bar-keymap global-map)) + (menu-bar-keymap (lookup-key global-map [menu-bar]))) menu) (defun context-menu-local (menu _click) @@ -377,7 +377,7 @@ Some context functions add menu items below the separator." (when (consp binding) (define-key-after menu (vector key) (copy-sequence binding)))) - keymap))) + (menu-bar-keymap keymap)))) menu) (defun context-menu-minor (menu _click) @@ -541,8 +541,11 @@ activates the menu whose contents depends on its surrounding context." "Start key navigation of the context menu. This is the keyboard interface to \\[context-menu-map]." (interactive) - (let ((inhibit-mouse-event-check t)) - (popup-menu (context-menu-map) (point)))) + (let ((inhibit-mouse-event-check t) + (map (context-menu-map))) + (if (commandp map) + (call-interactively map) + (popup-menu map (point))))) (global-set-key [S-f10] 'context-menu-open) @@ -1627,7 +1630,11 @@ The region will be defined with mark and point." (goto-char (nth 1 range))) (setf (terminal-parameter nil 'mouse-drag-start) start-event) - (setq track-mouse t) + ;; Set 'track-mouse' to something neither nil nor t, so that mouse + ;; events are not reported to have happened on the tool bar or the + ;; tab bar, as that breaks drag events that originate on the window + ;; body below these bars; see make_lispy_position and bug#51794. + (setq track-mouse 'drag-tracking) (set-transient-map (let ((map (make-sparse-keymap))) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 4627142757b..d04139d1489 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -55,29 +55,47 @@ (mouse-wheel-mode 1))) (defcustom mouse-wheel-down-event - (cond ((or (featurep 'w32-win) (featurep 'ns-win)) - 'wheel-up) - ((featurep 'pgtk-win) - '(mouse-4 wheel-up)) - (t - 'mouse-4)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (featurep 'pgtk-win)) + 'wheel-up + 'mouse-4) "Event used for scrolling down." :group 'mouse :type 'symbol :set 'mouse-wheel-change-button) +(defcustom mouse-wheel-down-alternate-event + (if (featurep 'xinput2) + 'wheel-up + (unless (featurep 'x) + 'mouse-4)) + "Alternative wheel down event to consider." + :group 'mouse + :type 'symbol + :version "29.1" + :set 'mouse-wheel-change-button) + (defcustom mouse-wheel-up-event - (cond ((or (featurep 'w32-win) (featurep 'ns-win)) - 'wheel-down) - ((featurep 'pgtk-win) - '(mouse-5 wheel-down)) - (t - 'mouse-5)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (feautrep 'pgtk-win)) + 'wheel-down + 'mouse-5) "Event used for scrolling up." :group 'mouse :type 'symbol :set 'mouse-wheel-change-button) +(defcustom mouse-wheel-up-alternate-event + (if (featurep 'xinput2) + 'wheel-down + (unless (featurep 'x) + 'mouse-5)) + "Alternative wheel up event to consider." + :group 'mouse + :type 'symbol + :version "29.1" + :set 'mouse-wheel-change-button) + (defcustom mouse-wheel-click-event 'mouse-2 "Event that should be temporarily inhibited after mouse scrolling. The mouse wheel is typically on the mouse-2 button, so it may easily @@ -227,23 +245,33 @@ Also see `mouse-wheel-tilt-scroll'." "Function that does the job of scrolling right.") (defvar mouse-wheel-left-event - (cond ((or (featurep 'w32-win) (featurep 'ns-win)) - 'wheel-left) - ((featurep 'pgtk-win) - '(mouse-6 wheel-left)) - (t - 'mouse-6)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (featurep 'pgtk-win)) + 'wheel-left + 'mouse-6) "Event used for scrolling left.") +(defvar mouse-wheel-left-alternate-event + (if (featurep 'xinput2) + 'wheel-left + (unless (featurep 'x) + 'mouse-8)) + "Alternative wheel left event to consider.") + (defvar mouse-wheel-right-event - (cond ((or (featurep 'w32-win) (featurep 'ns-win)) - 'wheel-right) - ((featurep 'pgtk-win) - '(mouse-7 wheel-right)) - (t - 'mouse-7)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (featurep 'pgtk-win)) + 'wheel-right + 'mouse-7) "Event used for scrolling right.") +(defvar mouse-wheel-right-alternate-event + (if (featurep 'xinput2) + 'wheel-right + (unless (featurep 'x) + 'mouse-7)) + "Alternative wheel right event to consider.") + (defun mouse-wheel--get-scroll-window (event) "Return window for mouse wheel event EVENT. If `mouse-wheel-follow-mouse' is non-nil, return the window that @@ -271,18 +299,6 @@ active window." frame nil t))))) (mwheel-event-window event))) -(defun mouse-wheel--button-eq (btn lst) - "Test whether BTN is included in LST." - (cond ((listp lst) - (memq btn lst)) - (t - (eq lst btn)) - )) - -(defun mouse-wheel--button-flatten (&rest arg) - "Flatten ARG." - (flatten-list arg)) - (defun mwheel-scroll (event &optional arg) "Scroll up or down according to the EVENT. This should be bound only to mouse buttons 4, 5, 6, and 7 on @@ -320,14 +336,16 @@ value of ARG, and the command uses it in subsequent scrolls." (condition-case nil (unwind-protect (let ((button (mwheel-event-button event))) - (cond ((and (eq amt 'hscroll) (mouse-wheel--button-eq button mouse-wheel-down-event)) + (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event))) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function) mouse-wheel-scroll-amount-horizontal)) - ((mouse-wheel--button-eq button mouse-wheel-down-event) + ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (condition-case nil (funcall mwheel-scroll-down-function amt) ;; Make sure we do indeed scroll to the beginning of ;; the buffer. @@ -342,23 +360,27 @@ value of ARG, and the command uses it in subsequent scrolls." ;; for a reason that escapes me. This problem seems ;; to only affect scroll-down. --Stef (set-window-start (selected-window) (point-min)))))) - ((and (eq amt 'hscroll) (mouse-wheel--button-eq button mouse-wheel-up-event)) + ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event))) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) mouse-wheel-scroll-amount-horizontal)) - ((mouse-wheel--button-eq button mouse-wheel-up-event) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (condition-case nil (funcall mwheel-scroll-up-function amt) ;; Make sure we do indeed scroll to the end of the buffer. (end-of-buffer (while t (funcall mwheel-scroll-up-function))))) - ((eq button mouse-wheel-left-event) ; for tilt scroll + ((memq button (list mouse-wheel-left-event + mouse-wheel-left-alternate-event)) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) amt))) - ((eq button mouse-wheel-right-event) ; for tilt scroll + ((memq button (list mouse-wheel-right-event + mouse-wheel-right-alternate-event)) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function @@ -402,9 +424,11 @@ value of ARG, and the command uses it in subsequent scrolls." (button (mwheel-event-button event))) (select-window scroll-window 'mark-for-redisplay) (unwind-protect - (cond ((mouse-wheel--button-eq button mouse-wheel-down-event) + (cond ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (text-scale-increase 1)) - ((mouse-wheel--button-eq button mouse-wheel-up-event) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (text-scale-decrease 1))) (select-window selected-window)))) @@ -456,18 +480,23 @@ an event used for scrolling, such as `mouse-wheel-down-event'." (cond ;; Bindings for changing font size. ((and (consp binding) (eq (cdr binding) 'text-scale)) - (dolist (event (mouse-wheel--button-flatten mouse-wheel-down-event - mouse-wheel-up-event)) - (mouse-wheel--add-binding `[,(list (caar binding) event)] - 'mouse-wheel-text-scale))) + (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event + mouse-wheel-down-alternate-event + mouse-wheel-up-alternate-event)) + (when event + (mouse-wheel--add-binding `[,(list (caar binding) event)] + 'mouse-wheel-text-scale)))) ;; Bindings for scrolling. (t - (dolist (event (mouse-wheel--button-flatten mouse-wheel-down-event - mouse-wheel-up-event - mouse-wheel-left-event - mouse-wheel-right-event)) - (dolist (key (mouse-wheel--create-scroll-keys binding event)) - (mouse-wheel--add-binding key 'mwheel-scroll))))))) + (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event + mouse-wheel-left-event mouse-wheel-right-event + mouse-wheel-down-alternate-event + mouse-wheel-up-alternate-event + mouse-wheel-left-alternate-event + mouse-wheel-right-alternate-event)) + (when event + (dolist (key (mouse-wheel--create-scroll-keys binding event)) + (mouse-wheel--add-binding key 'mwheel-scroll)))))))) (when mouse-wheel-mode (mouse-wheel--setup-bindings)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 1fafed32e6c..b1f981f28e6 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,6 +39,7 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany Epiphany Don't know +;; browse-url-webpositive WebPositive 1.2-alpha (Haiku R1/beta3) ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -156,6 +157,7 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "Epiphany" :value browse-url-epiphany) + (function-item :tag "WebPositive" :value browse-url-webpositive) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -366,6 +368,11 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(defcustom browse-url-webpositive-program "WebPositive" + "The name by which to invoke WebPositive." + :type 'string + :version "29.1") + ;; GNOME means of invoking either Mozilla or Netscape. (defvar browse-url-gnome-moz-program "gnome-moz-remote") @@ -730,7 +737,7 @@ position clicked before acting. This function returns a list (URL NEW-WINDOW-FLAG) for use in `interactive'." (let ((event (elt (this-command-keys) 0))) - (and (listp event) (mouse-set-point event))) + (mouse-set-point event)) (list (read-string prompt (or (and transient-mark-mode mark-active ;; rfc2396 Appendix E. (replace-regexp-in-string @@ -1059,6 +1066,7 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-kde-program) 'browse-url-kde) ;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ((executable-find browse-url-chrome-program) 'browse-url-chrome) + ((executable-find browse-url-webpositive-program) 'browse-url-webpositive) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t @@ -1385,6 +1393,18 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) +;;;###autoload +(defun browse-url-webpositive (url &optional _new-window) + "Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((process-environment (browse-url-process-environment))) + (start-process (concat "WebPositive " url) nil "WebPositive" url))) + +(function-put 'browse-url-webpositive 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-emacs (url &optional same-window) "Ask Emacs to load URL into a buffer and show it in another window. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 46e211171e6..0c66cf3a0d7 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -239,7 +239,7 @@ parameter, and should return the (possibly) transformed URL." :version "29.1") (defface eww-form-submit - '((((type x w32 ns pgtk) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -247,7 +247,7 @@ parameter, and should return the (possibly) transformed URL." :group 'eww) (defface eww-form-file - '((((type x w32 ns pgtk) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -255,7 +255,7 @@ parameter, and should return the (possibly) transformed URL." :group 'eww) (defface eww-form-checkbox - '((((type x w32 ns pgtk) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -263,7 +263,7 @@ parameter, and should return the (possibly) transformed URL." :group 'eww) (defface eww-form-select - '((((type x w32 ns pgtk) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -314,11 +314,11 @@ parameter, and should return the (possibly) transformed URL." (defvar-keymap eww-link-keymap :parent shr-map - "\r" #'eww-follow-link) + "RET" #'eww-follow-link) (defvar-keymap eww-image-link-keymap :parent shr-map - "\r" #'eww-follow-link) + "RET" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -1045,11 +1045,11 @@ the like." (defvar-keymap eww-mode-map "g" #'eww-reload ;FIXME: revert-buffer-function instead! "G" #'eww - [?\M-\r] #'eww-open-in-new-buffer - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [backtab] #'shr-previous-link - [delete] #'scroll-down-command + "M-RET" #'eww-open-in-new-buffer + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "" #'shr-previous-link + "" #'scroll-down-command "l" #'eww-back-url "r" #'eww-forward-url "n" #'eww-next-url @@ -1068,16 +1068,16 @@ the like." "S" #'eww-list-buffers "F" #'eww-toggle-fonts "D" #'eww-toggle-paragraph-direction - [(meta C)] #'eww-toggle-colors - [(meta I)] #'eww-toggle-images + "M-C" #'eww-toggle-colors + "M-I" #'eww-toggle-images "b" #'eww-add-bookmark "B" #'eww-list-bookmarks - [(meta n)] #'eww-next-bookmark - [(meta p)] #'eww-previous-bookmark + "M-n" #'eww-next-bookmark + "M-p" #'eww-previous-bookmark - [(mouse-8)] #'eww-back-url - [(mouse-9)] #'eww-forward-url + "" #'eww-back-url + "" #'eww-forward-url :menu '("Eww" ["Exit" quit-window t] @@ -1300,42 +1300,42 @@ just re-display the HTML already fetched." (defvar eww-form nil) (defvar-keymap eww-submit-map - "\r" #'eww-submit - [(control c) (control c)] #'eww-submit) + "RET" #'eww-submit + "C-c C-c" #'eww-submit) (defvar-keymap eww-submit-file - "\r" #'eww-select-file - [(control c) (control c)] #'eww-submit) + "RET" #'eww-select-file + "C-c C-c" #'eww-submit) (defvar-keymap eww-checkbox-map - " " #'eww-toggle-checkbox - "\r" #'eww-toggle-checkbox - [(control c) (control c)] #'eww-submit) + "SPC" #'eww-toggle-checkbox + "RET" #'eww-toggle-checkbox + "C-c C-c" #'eww-submit) (defvar-keymap eww-text-map :full t :parent text-mode-map - "\r" #'eww-submit - [(control a)] #'eww-beginning-of-text - [(control c) (control c)] #'eww-submit - [(control e)] #'eww-end-of-text - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [backtab] #'shr-previous-link) + "RET" #'eww-submit + "C-a" #'eww-beginning-of-text + "C-c C-c" #'eww-submit + "C-e" #'eww-end-of-text + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "" #'shr-previous-link) (defvar-keymap eww-textarea-map :full t :parent text-mode-map - "\r" #'forward-line - [(control c) (control c)] #'eww-submit - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [backtab] #'shr-previous-link) + "RET" #'forward-line + "C-c C-c" #'eww-submit + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "" #'shr-previous-link) (defvar-keymap eww-select-map :doc "Map for select buttons" - "\r" #'eww-change-select - [follow-link] 'mouse-face - [mouse-2] #'eww-change-select - [(control c) (control c)] #'eww-submit) + "RET" #'eww-change-select + "" 'mouse-face + "" #'eww-change-select + "C-c C-c" #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -2171,9 +2171,9 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (eww-browse-url (plist-get bookmark :url)))) (defvar-keymap eww-bookmark-mode-map - [(control k)] #'eww-bookmark-kill - [(control y)] #'eww-bookmark-yank - "\r" #'eww-bookmark-browse + "C-k" #'eww-bookmark-kill + "C-y" #'eww-bookmark-yank + "RET" #'eww-bookmark-browse :menu '("Eww Bookmark" ["Exit" quit-window t] ["Browse" eww-bookmark-browse @@ -2247,7 +2247,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (eww-restore-history history))) (defvar-keymap eww-history-mode-map - "\r" #'eww-history-browse + "RET" #'eww-history-browse "n" #'next-line "p" #'previous-line :menu '("Eww History" @@ -2366,8 +2366,8 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (eww-buffer-show)) (defvar-keymap eww-buffers-mode-map - [(control k)] #'eww-buffer-kill - "\r" #'eww-buffer-select + "C-k" #'eww-buffer-kill + "RET" #'eww-buffer-select "n" #'eww-buffer-show-next "p" #'eww-buffer-show-previous :menu '("Eww Buffers" diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 2c687557181..14d49251f55 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -55,7 +55,7 @@ you have an entry for \"image/*\" in your ~/.mailcap file." "A syntax table for parsing SGML attributes.") (defvar mailcap-print-command - (mapconcat 'identity + (mapconcat #'identity (cons (if (boundp 'lpr-command) lpr-command "lpr") @@ -116,8 +116,7 @@ is consulted." (regexp :tag "MIME Type") (sexp :tag "Test (optional)"))) :get #'mailcap--get-user-mime-data - :set #'mailcap--set-user-mime-data - :group 'mailcap) + :set #'mailcap--set-user-mime-data) ;; Postpone using defcustom for this as it's so big and we essentially ;; have to have two copies of the data around then. Perhaps just @@ -344,8 +343,7 @@ Same format as `mailcap-mime-data'.") "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." :type '(choice (const :tag "Home directory" nil) - directory) - :group 'mailcap) + directory)) (defvar mailcap-poor-system-types '(ms-dos windows-nt) @@ -439,6 +437,8 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/etc/mailcap" system) ("/usr/etc/mailcap" system) ("/usr/local/etc/mailcap" system))))) + (when (stringp path) + (setq path (mapcar #'list (split-string path path-separator t)))) (when (seq-some (lambda (f) (file-has-changed-p (car f) 'mail-parse-mailcaps)) path) @@ -451,14 +451,9 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus do (cl-loop for (minor . entry) in minors do (mailcap-add-mailcap-entry major minor entry))) ;; The ~/.mailcap entries will end up first in the resulting data. - (dolist (spec (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (let ((source (and (consp spec) (cadr spec))) - (file-name (if (stringp spec) - spec - (car spec)))) + (dolist (spec (reverse path)) + (let ((source (cadr spec)) + (file-name (car spec))) (when (and (file-readable-p file-name) (file-regular-p file-name)) (mailcap-parse-mailcap file-name source))))) @@ -639,7 +634,7 @@ the test clause will be unchanged." ((and (listp test) (symbolp (car test))) test) ((or (stringp test) (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) + (setq test (mapconcat #'identity test " ")))) (with-temp-buffer (insert test) (goto-char (point-min)) @@ -710,12 +705,12 @@ to supply to the test." (symbol-value test)) ((and (listp test) ; List to be eval'd (symbolp (car test))) - (eval test)) + (eval test t)) (t (setq test (mailcap-unescape-mime-test test type-info) test (list shell-file-name nil nil nil shell-command-switch test) - status (apply 'call-process test)) + status (apply #'call-process test)) (eq 0 status)))) (push (list otest result) mailcap-viewer-test-cache) result)))) @@ -840,7 +835,7 @@ If NO-DECODE is non-nil, don't decode STRING." (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp)) + (setq passed (sort (nreverse passed) #'mailcap-viewer-lessp)) ;; When we want to prefer entries from the user's ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. @@ -1070,7 +1065,7 @@ For instance, \"foo.png\" will result in \"image/png\"." ;;;###autoload (defun mailcap-mime-type-to-extension (mime-type) - "Return a file name extension based on a mime type. + "Return a file name extension based on a MIME-TYPE. For instance, `image/png' will result in `png'." (intern (cadr (split-string (if (symbolp mime-type) (symbol-name mime-type) @@ -1082,7 +1077,7 @@ For instance, `image/png' will result in `png'." (mailcap-parse-mimetypes) (delete-dups (nconc - (mapcar 'cdr mailcap-mime-extensions) + (mapcar #'cdr mailcap-mime-extensions) (let (res type) (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 42a7e796798..c1833ffdb0b 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -43,6 +43,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." "Encode STRING according to the IDNA/punycode algorithm. This is used to encode non-ASCII domain names. For instance, \"bücher\" => \"xn--bcher-kva\"." + (setq string (downcase (string-glyph-compose string))) (let ((ascii (seq-filter (lambda (char) (< char 128)) string))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 52d74a33945..b4e9031e0d4 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -262,6 +262,7 @@ The ARGUMENTS for each METHOD symbol are: `bitlbee': NICK PASSWORD `quakenet': ACCOUNT PASSWORD `sasl': NICK PASSWORD + `certfp': KEY CERT Examples: ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") @@ -291,7 +292,11 @@ Examples: (list :tag "SASL" (const sasl) (string :tag "Nick") - (string :tag "Password"))))) + (string :tag "Password")) + (list :tag "CertFP" + (const certfp) + (string :tag "Key") + (string :tag "Certificate"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. @@ -547,6 +552,9 @@ If ARG is non-nil, instead prompt for connection parameters." (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) + (client-cert (when (eq (rcirc-get-server-method (car c)) + 'certfp) + (rcirc-get-server-cert (car c)))) contact) (when-let (((not password)) (auth (auth-source-search :host server @@ -563,7 +571,7 @@ If ARG is non-nil, instead prompt for connection parameters." (condition-case nil (let ((process (rcirc-connect server port nick user-name full-name channels password encryption - server-alias))) + client-cert server-alias))) (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) (quit (message "Quit connecting to %s" @@ -646,29 +654,23 @@ See `rcirc-connect' for more details on these variables.") (defun rcirc-get-server-method (server) "Return authentication method for SERVER." - (catch 'method - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (method (cadr i))) - (when (string-match server-i server) - (throw 'method method)))))) + (cadr (assoc server rcirc-authinfo #'string-match))) (defun rcirc-get-server-password (server) "Return password for SERVER." - (catch 'pass - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (args (cdddr i))) - (when (string-match server-i server) - (throw 'pass (car args))))))) + (cadddr (assoc server rcirc-authinfo #'string-match))) + +(defun rcirc-get-server-cert (server) + "Return a list of key and certificate for SERVER." + (cddr (assoc server rcirc-authinfo #'string-match))) ;;;###autoload (defun rcirc-connect (server &optional port nick user-name full-name startup-channels password encryption - server-alias) + certfp server-alias) "Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication." (save-excursion @@ -695,6 +697,7 @@ that are joined after authentication." (setq process (open-network-stream (or server-alias server) nil server port-number :type (or encryption 'plain) + :client-certificate certfp :nowait t)) (set-process-coding-system process 'raw-text 'raw-text) (with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil)) @@ -2583,7 +2586,7 @@ that, an interactive form can specified." ,(concat documentation "\n\nNote: If PROCESS or TARGET are nil, the values given" "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - (interactive ,interactive-spec) + (interactive (list ,interactive-spec)) (unless (if (listp ,argument) (<= ,required (length ,argument) ,total) (string-match ,regexp ,argument)) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index fd7469389ad..d59b0ed3629 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -162,6 +162,10 @@ cid: URL as the argument.") (defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") +(defface shr-text '((t :inherit variable-pitch)) + "Face used for rendering text." + :version "29.1") + (defface shr-strike-through '((t :strike-through t)) "Face for elements." :version "24.1") @@ -183,6 +187,11 @@ temporarily blinks with this face." "Face for elements." :version "27.1") +(defface shr-sup + '((t :height 0.8)) + "Face for and elements." + :version "29.1") + (defface shr-h1 '((t :height 1.3 :weight bold)) "Face for

elements." @@ -251,17 +260,17 @@ and other things: "a" #'shr-show-alt-text "i" #'shr-browse-image "z" #'shr-zoom-image - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [follow-link] 'mouse-face - [mouse-2] #'shr-browse-url - [C-down-mouse-1] #'shr-mouse-browse-url-new-window + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "" 'mouse-face + "" #'shr-browse-url + "C-" #'shr-mouse-browse-url-new-window "I" #'shr-insert-image "w" #'shr-maybe-probe-and-copy-url "u" #'shr-maybe-probe-and-copy-url "v" #'shr-browse-url "O" #'shr-save-contents - "\r" #'shr-browse-url) + "RET" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) @@ -737,7 +746,7 @@ size, and full-buffer size." (when shr-use-fonts (put-text-property font-start (point) 'face - (or shr-current-font 'variable-pitch))))))))) + (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) (if (<= shr-internal-width 0) @@ -1464,12 +1473,14 @@ ones, in case fg and bg are nil." (defun shr-tag-sup (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise 0.2)))) + (put-text-property start (point) 'display '(raise 0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise -0.2)))) + (put-text-property start (point) 'display '(raise -0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-p (dom) (shr-ensure-paragraph) @@ -1697,7 +1708,7 @@ The preference is a float determined from `shr-prefer-media-type'." (xwidget-webkit-execute-script widget (format "document.body.innerHTML = %S;" (format - "
" + "
" url))))) ;; No xwidgets. (if (> (length image) 0) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 374e5db5879..341357d404c 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -107,7 +107,8 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -119,7 +120,6 @@ It is used for TCP/IP devices." (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-adb-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-adb-handle-exec-path) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 578f9fcf913..efd38e6b4b7 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -211,7 +211,8 @@ It must be supported by libarchive(3).") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-archive-file-name-handler-alist - '((access-file . tramp-archive-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-archive-handle-access-file) (add-name-to-file . tramp-archive-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. @@ -223,7 +224,6 @@ It must be supported by libarchive(3).") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . tramp-archive-handle-not-implemented) (dired-uncache . tramp-archive-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 5e7d24ff72b..f2be297d59c 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -224,7 +224,9 @@ Return VALUE." (defun tramp-flush-file-upper-properties (key file) "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) - (let ((file (directory-file-name (file-name-directory file)))) + ;; `file-name-directory' can return nil, for example for "~". + (when-let ((file (file-name-directory file)) + (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index f431f975633..4ff8e6bbf12 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -157,7 +157,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist - '((access-file . tramp-crypt-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-crypt-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -169,7 +170,6 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (directory-files . tramp-crypt-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -486,6 +486,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'." Files in that directory and all subdirectories will be encrypted before copying to, and decrypted after copying from that directory. File names will be also encrypted." + ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 11de71aa0d9..ab71c9cd13f 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -744,7 +744,8 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -756,7 +757,6 @@ It has been changed in GVFS 1.14.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -1149,15 +1149,12 @@ file names." (make-tramp-file-name :method method :user user :domain domain :host host :port port :localname "/" :hop hop))) - (setq localname - (replace-match - (tramp-get-connection-property v "default-location" "~") - nil t localname 1))) - ;; Tilde expansion is not possible. - (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (tramp-error - v 'file-error - "Cannot expand tilde in file `%s'" name)) + (unless (string-empty-p + (tramp-get-connection-property v "default-location" "")) + (setq localname + (replace-match + (tramp-get-connection-property v "default-location" "~") + nil t localname 1)))) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". @@ -1172,10 +1169,12 @@ file names." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (tramp-run-real-handler #'expand-file-name (list localname)))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index c997215a15b..09862c6a04c 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-rclone-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -83,7 +84,6 @@ (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 533ddcf66ea..b83569f3ded 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -34,6 +34,8 @@ (eval-when-compile (require 'cl-lib)) (require 'tramp) +;; `dired-*' declarations can be removed, starting with Emacs 29.1. +(declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) (defvar process-file-return-signal-string) @@ -940,7 +942,8 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -952,7 +955,8 @@ Format specifiers \"%s\" are replaced before the script is used.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + ;; Starting with Emacs 29.1, `dired-compress-file' performed by + ;; default handler. (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sh-handle-exec-path) @@ -2472,57 +2476,60 @@ The method used must be an out-of-band method." ;; Dired. -;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-properties v localname) - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match-p (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (if (>= emacs-major-version 29) + (tramp-run-real-handler #'dired-compress-file (list file)) + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) - (cond ((file-symlink-p file) nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (if (string-match-p "%[io]" (nth 2 suffix)) - (replace-regexp-in-string - "%i" (tramp-shell-quote-argument localname) - (nth 2 suffix)) - (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname)))) - (unless (string-match-p "\\.tar\\.gz" file) - (dired-remove-file file)) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (if (file-directory-p file) - (format "tar -cf - %s | gzip -c9 > %s.tar.gz" - (tramp-shell-quote-argument - (file-name-nondirectory localname)) - (tramp-shell-quote-argument localname)) - (concat "gzip -f " - (tramp-shell-quote-argument localname)))) - (unless (file-directory-p file) - (dired-remove-file file)) - (catch 'found nil - (dolist (target (mapcar (lambda (suffix) - (concat file suffix)) - '(".tar.gz" ".gz" ".z"))) - (when (file-exists-p target) - (throw 'found target))))))))))) + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (if (string-match-p "%[io]" (nth 2 suffix)) + (replace-regexp-in-string + "%i" (tramp-shell-quote-argument localname) + (nth 2 suffix)) + (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname)))) + (unless (string-match-p "\\.tar\\.gz" file) + (dired-remove-file file)) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so + ;; compress it. Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (if (file-directory-p file) + (format "tar -cf - %s | gzip -c9 > %s.tar.gz" + (tramp-shell-quote-argument + (file-name-nondirectory localname)) + (tramp-shell-quote-argument localname)) + (concat "gzip -f " + (tramp-shell-quote-argument localname)))) + (unless (file-directory-p file) + (dired-remove-file file)) + (catch 'found nil + (dolist (target (mapcar (lambda (suffix) + (concat file suffix)) + '(".tar.gz" ".gz" ".z"))) + (when (file-exists-p target) + (throw 'found target)))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index ac567dc0747..24119539db0 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) @@ -234,7 +235,6 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-smb-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index fc77d998aa6..a19c99316e6 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sshfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -83,7 +84,6 @@ (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sshfs-handle-exec-path) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 842990488ef..c91bced656c 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -63,7 +63,8 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) (copy-directory . tramp-handle-copy-directory) @@ -75,7 +76,6 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f4493608a46..f43c1d84b87 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1677,6 +1677,8 @@ If it's not a Tramp filename, return nil." ((tramp-tramp-file-p vec-or-filename) (tramp-dissect-file-name vec-or-filename)))) +(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." @@ -1902,29 +1904,55 @@ The outline level is equal to the verbosity of the Tramp message." (put #'tramp-debug-outline-level 'tramp-suppress-trace t) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-debug-buffer-command-completion-p (_symbol buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only in Tramp debug buffers." + (with-current-buffer buffer + (string-equal (buffer-substring 1 10) ";; Emacs:"))) + +(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) + +(defun tramp-setup-debug-buffer () + "Function to setup debug buffers." + ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (interactive) + (set-buffer-file-coding-system 'utf-8) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes die. + ;; Yes: I've seen `flyspell-mode', which starts "ispell". + ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises + ;; on error in `(outline-mode)', we don't want to see it in the + ;; traces. + (let ((default-directory tramp-compat-temporary-file-directory)) + (outline-mode)) + (setq-local outline-level 'tramp-debug-outline-level) + (setq-local font-lock-keywords + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an internal + ;; implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map) + ;; For debugging purposes. + (local-set-key "\M-n" 'clone-buffer) + (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) + +(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) + +(function-put + #'tramp-setup-debug-buffer 'completion-predicate + #'tramp-debug-buffer-command-completion-p) + (defun tramp-get-debug-buffer (vec) "Get the debug buffer for VEC." (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) - (set-buffer-file-coding-system 'utf-8) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; `(custom-declare-variable outline-minor-mode-prefix ...)' - ;; raises on error in `(outline-mode)', we don't want to see it - ;; in the traces. - (let ((default-directory tramp-compat-temporary-file-directory)) - (outline-mode)) - (setq-local outline-level 'tramp-debug-outline-level) - (setq-local font-lock-keywords - ;; FIXME: This `(t FOO . BAR)' representation in - ;; `font-lock-keywords' is supposed to be an - ;; internal implementation "detail". Don't abuse it here! - `(t (eval ,tramp-debug-font-lock-keywords t) - ,(eval tramp-debug-font-lock-keywords t))) - ;; Do not edit the debug buffer. - (use-local-map special-mode-map)) + (tramp-setup-debug-buffer)) (current-buffer))) (put #'tramp-get-debug-buffer 'tramp-suppress-trace t) @@ -2476,28 +2504,27 @@ Must be handled by the callers." '(access-file byte-compiler-base-file-name delete-directory delete-file diff-latest-backup-file directory-file-name directory-files directory-files-and-attributes - dired-uncache file-acl file-accessible-directory-p - file-attributes file-directory-p file-executable-p - file-exists-p file-local-copy file-modes - file-name-as-directory file-name-case-insensitive-p - file-name-directory file-name-nondirectory - file-name-sans-versions file-notify-add-watch - file-ownership-preserved-p file-readable-p - file-regular-p file-remote-p file-selinux-context - file-symlink-p file-truename file-writable-p - find-backup-file-name get-file-buffer insert-directory - insert-file-contents load make-directory - make-directory-internal set-file-acl set-file-modes - set-file-selinux-context set-file-times + dired-compress-file dired-uncache file-acl + file-accessible-directory-p file-attributes + file-directory-p file-executable-p file-exists-p + file-local-copy file-modes file-name-as-directory + file-name-case-insensitive-p file-name-directory + file-name-nondirectory file-name-sans-versions + file-notify-add-watch file-ownership-preserved-p + file-readable-p file-regular-p file-remote-p + file-selinux-context file-symlink-p file-truename + file-writable-p find-backup-file-name get-file-buffer + insert-directory insert-file-contents load + make-directory make-directory-internal set-file-acl + set-file-modes set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. file-locked-p lock-file make-lock-file-name unlock-file - ;; Starting with Emacs 29.1, `dired-compress-file' isn't - ;; magic anymore. - dired-compress-file + ;; Emacs 29+ only. + abbreviate-file-name ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) @@ -2555,13 +2582,20 @@ Must be handled by the callers." (when (tramp-tramp-file-p filename) (let ((handler tramp-foreign-file-name-handler-alist) (vec (tramp-dissect-file-name filename)) - elt res) + elt func res) (while handler (setq elt (car handler) handler (cdr handler)) ;; Previously, this function was called with FILENAME, but now ;; it's called with the VEC. - (when (with-demoted-errors "Error: %S" (funcall (car elt) vec)) + (when (condition-case nil + (funcall (setq func (car elt)) vec) + (error + (setcar elt #'ignore) + (unless (member 'remote-file-error debug-ignored-errors) + (tramp-error + vec 'remote-file-error + "Not a valid Tramp file name function `%s'" func)))) (setq handler nil res (cdr elt)))) res))) @@ -3278,6 +3312,28 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +;; `directory-abbrev-apply' and `directory-abbrev-make-regexp' exists +;; since Emacs 29.1. Since this handler isn't called for older +;; Emacsen, it is save to invoke them via `tramp-compat-funcall'. +(defun tramp-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (vec (tramp-dissect-file-name filename)) + (home-dir + (with-tramp-connection-property vec "home-directory" + (tramp-compat-funcall + 'directory-abbrev-apply + (expand-file-name (tramp-make-tramp-file-name vec "~")))))) + ;; If any elt of `directory-abbrev-alist' matches this name, + ;; abbreviate accordingly. + (setq filename (tramp-compat-funcall 'directory-abbrev-apply filename)) + ;; Abbreviate home directory. + (if (string-match + (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename) + (tramp-make-tramp-file-name + vec (concat "~" (substring filename (match-beginning 1)))) + filename))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3398,13 +3454,16 @@ User is always nil." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. ;; `default-directory' is bound, because on Windows there would ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory tramp-compat-temporary-file-directory)) (tramp-make-tramp-file-name - v (tramp-drop-volume-letter - (tramp-run-real-handler #'expand-file-name (list localname)))))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-drop-volume-letter + (tramp-run-real-handler #'expand-file-name (list localname))))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." diff --git a/lisp/org/oc-csl.el b/lisp/org/oc-csl.el index 7cd63c3ff3a..7f078d139b1 100644 --- a/lisp/org/oc-csl.el +++ b/lisp/org/oc-csl.el @@ -283,7 +283,8 @@ Label is in match group 1.") ;;; Internal functions (defun org-cite-csl--barf-without-citeproc () "Raise an error if Citeproc library is not loaded." - (unless (featurep 'citeproc) "Citeproc library is not loaded")) + (unless (featurep 'citeproc) + (error "Citeproc library is not loaded"))) (defun org-cite-csl--note-style-p (info) "Non-nil when bibliography style implies wrapping citations in footnotes. diff --git a/lisp/org/oc.el b/lisp/org/oc.el index 41fd688c060..427c087c036 100644 --- a/lisp/org/oc.el +++ b/lisp/org/oc.el @@ -1141,17 +1141,14 @@ and must return either a string, an object, or a secondary string." ;;; Internal interface with fontification (activate capability) -(defun org-cite-fontify-default (datum) - "Fontify DATUM with `org-cite' and `org-cite-key' face. -DATUM is a citation object, or a citation reference. In any case, apply -`org-cite' face on the whole citation, and `org-cite-key' face on each key." - (let* ((cite (if (eq 'citation-reference (org-element-type datum)) - (org-element-property :parent datum) - datum)) - (beg (org-element-property :begin cite)) - (end (org-with-point-at (org-element-property :end cite) - (skip-chars-backward " \t") - (point)))) +(defun org-cite-fontify-default (cite) + "Fontify CITE with `org-cite' and `org-cite-key' faces. +CITE is a citation object. The function applies `org-cite' face +on the whole citation, and `org-cite-key' face on each key." + (let ((beg (org-element-property :begin cite)) + (end (org-with-point-at (org-element-property :end cite) + (skip-chars-backward " \t") + (point)))) (add-text-properties beg end '(font-lock-multiline t)) (add-face-text-property beg end 'org-cite) (dolist (reference (org-cite-get-references cite)) @@ -1163,16 +1160,20 @@ DATUM is a citation object, or a citation reference. In any case, apply "Activate citations from up to LIMIT buffer position. Each citation encountered is activated using the appropriate function from the processor set in `org-cite-activate-processor'." - (let ((name org-cite-activate-processor)) - (let ((activate - (or (and name - (org-cite-processor-has-capability-p name 'activate) - (org-cite-processor-activate (org-cite--get-processor name))) - #'org-cite-fontify-default))) - (while (re-search-forward org-element-citation-prefix-re limit t) - (let ((cite (org-with-point-at (match-beginning 0) - (org-element-citation-parser)))) - (when cite (save-excursion (funcall activate cite)))))))) + (let* ((name org-cite-activate-processor) + (activate + (or (and name + (org-cite-processor-has-capability-p name 'activate) + (org-cite-processor-activate (org-cite--get-processor name))) + #'org-cite-fontify-default))) + (when (re-search-forward org-element-citation-prefix-re limit t) + (let ((cite (org-with-point-at (match-beginning 0) + (org-element-citation-parser)))) + (when cite + (funcall activate cite) + ;; Move after cite object and make sure to return + ;; a non-nil value. + (goto-char (org-element-property :end cite))))))) ;;; Internal interface with Org Export library (export capability) diff --git a/lisp/org/org-goto.el b/lisp/org/org-goto.el index 0a3470f5451..352bf9f2e52 100644 --- a/lisp/org/org-goto.el +++ b/lisp/org/org-goto.el @@ -203,40 +203,39 @@ When nil, you can use these keybindings to navigate the buffer: "Let the user select a location in current buffer. This function uses a recursive edit. It returns the selected position or nil." - (org-no-popups - (let ((isearch-mode-map org-goto-local-auto-isearch-map) - (isearch-hide-immediately nil) - (isearch-search-fun-function - (lambda () #'org-goto--local-search-headings)) - (help (or help org-goto-help))) - (save-excursion - (save-window-excursion - (delete-other-windows) - (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) - (pop-to-buffer-same-window - (condition-case nil - (make-indirect-buffer (current-buffer) "*org-goto*" t) - (error (make-indirect-buffer (current-buffer) "*org-goto*" t)))) - (let (temp-buffer-show-function temp-buffer-show-hook) - (with-output-to-temp-buffer "*Org Help*" - (princ (format help (if org-goto-auto-isearch - " Just type for auto-isearch." - " n/p/f/b/u to navigate, q to quit."))))) - (org-fit-window-to-buffer (get-buffer-window "*Org Help*")) - (org-overview) - (setq buffer-read-only t) - (if (and (boundp 'org-goto-start-pos) - (integer-or-marker-p org-goto-start-pos)) - (progn (goto-char org-goto-start-pos) - (when (org-invisible-p) - (org-show-set-visibility 'lineage))) - (goto-char (point-min))) - (let (org-special-ctrl-a/e) (org-beginning-of-line)) - (message "Select location and press RET") - (use-local-map org-goto-map) - (recursive-edit))) - (kill-buffer "*org-goto*") - (cons org-goto-selected-point org-goto-exit-command)))) + (let ((isearch-mode-map org-goto-local-auto-isearch-map) + (isearch-hide-immediately nil) + (isearch-search-fun-function + (lambda () #'org-goto--local-search-headings)) + (help (or help org-goto-help))) + (save-excursion + (save-window-excursion + (delete-other-windows) + (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) + (pop-to-buffer-same-window + (condition-case nil + (make-indirect-buffer (current-buffer) "*org-goto*" t) + (error (make-indirect-buffer (current-buffer) "*org-goto*" t)))) + (let (temp-buffer-show-function temp-buffer-show-hook) + (with-output-to-temp-buffer "*Org Help*" + (princ (format help (if org-goto-auto-isearch + " Just type for auto-isearch." + " n/p/f/b/u to navigate, q to quit."))))) + (org-fit-window-to-buffer (get-buffer-window "*Org Help*")) + (org-overview) + (setq buffer-read-only t) + (if (and (boundp 'org-goto-start-pos) + (integer-or-marker-p org-goto-start-pos)) + (progn (goto-char org-goto-start-pos) + (when (org-invisible-p) + (org-show-set-visibility 'lineage))) + (goto-char (point-min))) + (let (org-special-ctrl-a/e) (org-beginning-of-line)) + (message "Select location and press RET") + (use-local-map org-goto-map) + (recursive-edit))) + (kill-buffer "*org-goto*") + (cons org-goto-selected-point org-goto-exit-command))) ;;;###autoload (defun org-goto (&optional alternative-interface) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 89c57fb06ce..e34872fb491 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -4436,7 +4436,7 @@ Optional argument NEW may specify text to replace the current field content." (col (org-table-current-column))) (when (> col 0) (skip-chars-backward "^|") - (if (not (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)")) + (if (not (looking-at " *\\(?:\\([^|\n]*?\\) *\\(|\\)\\|\\([^|\n]+?\\) *\\($\\)\\)")) (setq org-table-may-need-update t) (let* ((align (nth (1- col) org-table-last-alignment)) (width (nth (1- col) org-table-last-column-widths)) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 6427f30072e..212069e668f 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -5,13 +5,13 @@ (defun org-release () "The release version of Org. Inserted by installing Org mode or when a release is made." - (let ((org-release "9.5")) + (let ((org-release "9.5.1")) org-release)) ;;;###autoload (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5-68-g77e2ec")) + (let ((org-git-version "release_9.5.1-11-g96d91b")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 83b3d79cb17..1a137546192 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -9,7 +9,7 @@ ;; Homepage: https://orgmode.org ;; Package-Requires: ((emacs "25.1")) -;; Version: 9.5 +;; Version: 9.5.1 ;; This file is part of GNU Emacs. ;; diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el index 9170059156d..081a28317f6 100644 --- a/lisp/org/ox-icalendar.el +++ b/lisp/org/ox-icalendar.el @@ -280,6 +280,7 @@ re-read the iCalendar file.") (footnote-definition . ignore) (footnote-reference . ignore) (headline . org-icalendar-entry) + (inner-template . org-icalendar-inner-template) (inlinetask . ignore) (planning . ignore) (section . ignore) @@ -805,6 +806,11 @@ END:VALARM\n" ;;;; Template +(defun org-icalendar-inner-template (contents _) + "Return document body string after iCalendar conversion. +CONTENTS is the transcoded contents string." + contents) + (defun org-icalendar-template (contents info) "Return complete document string after iCalendar conversion. CONTENTS is the transcoded contents string. INFO is a plist used diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 9ab813a1b14..b27ec56c08c 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -1048,6 +1048,7 @@ BACKEND is a structure with `org-export-backend' type." (unless (org-export-backend-p backend) (error "Unknown \"%s\" back-end: Aborting export" backend))) +;;;###autoload (defun org-export-derived-backend-p (backend &rest backends) "Non-nil if BACKEND is derived from one of BACKENDS. BACKEND is an export back-end, as returned by, e.g., @@ -1858,6 +1859,7 @@ INFO is a plist containing export directives." (let ((transcoder (cdr (assq type (plist-get info :translate-alist))))) (and (functionp transcoder) transcoder))))) +;;;###autoload (defun org-export-data (data info) "Convert DATA into current back-end format. @@ -4586,6 +4588,7 @@ objects of the same type." ;; `org-export-raw-string' builds a pseudo-object out of a string ;; that any export back-end returns as-is. +;;;###autoload (defun org-export-raw-string (s) "Return a raw object containing string S. A raw string is exported as-is, with no additional processing diff --git a/lisp/outline.el b/lisp/outline.el index cefb8117035..2ede4e23eac 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -221,7 +221,7 @@ in the file it applies to.") (defvar outline-font-lock-keywords '( ;; Highlight headings according to the level. - (eval . (list (concat "^\\(?:" outline-regexp "\\).+") + (eval . (list (concat "^\\(?:" outline-regexp "\\).*") 0 '(if outline-minor-mode (if outline-minor-mode-cycle (if outline-minor-mode-highlight @@ -992,8 +992,8 @@ If non-nil, EVENT should be a mouse event." (overlay-put o 'keymap (define-keymap :parent outline-minor-mode-cycle-map - ["RET"] #'outline-hide-subtree - [""] #'outline-hide-subtree))))) + "RET" #'outline-hide-subtree + "" #'outline-hide-subtree))))) (defun outline--insert-close-button () (save-excursion @@ -1003,8 +1003,8 @@ If non-nil, EVENT should be a mouse event." (overlay-put o 'keymap (define-keymap :parent outline-minor-mode-cycle-map - ["RET"] #'outline-show-subtree - [""] #'outline-show-subtree))))) + "RET" #'outline-show-subtree + "" #'outline-show-subtree))))) (defun outline--fix-up-all-buttons (&optional from to) (when from @@ -1014,7 +1014,10 @@ If non-nil, EVENT should be a mouse event." (when outline-minor-mode-use-buttons (outline-map-region (lambda () - (if (eq (outline--cycle-state) 'show-all) + ;; `outline--cycle-state' will fail if we're in a totally + ;; collapsed buffer -- but in that case, we're not in a + ;; `show-all' situation. + (if (eq (ignore-errors (outline--cycle-state)) 'show-all) (outline--insert-open-button) (outline--insert-close-button))) (or from (point-min)) (or to (point-max))))) diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 249484cf581..888320cf1ae 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -67,6 +67,7 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +91,15 @@ is always with pixel resolution.") (defvar pixel-last-scroll-time 0 "Time when the last scrolling was made, in second since the epoch.") +(defvar x-coalesce-scroll-events) + +(defvar pixel-scroll-precision-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [wheel-down] #'pixel-scroll-precision) + (define-key map [wheel-up] #'pixel-scroll-precision) + map) + "The key map used by `pixel-scroll-precision-mode'.") + (defun pixel-scroll-in-rush-p () "Return non-nil if next scroll should be non-smooth. When scrolling request is delivered soon after the previous one, @@ -323,28 +333,32 @@ returns nil." (setq pos-list (cdr pos-list)))) visible-pos)) -(defun pixel-point-at-unseen-line () - "Return the character position of line above the selected window. -The returned value is the position of the first character on the -unseen line just above the scope of current window." +(defun pixel-point-and-height-at-unseen-line () + "Return the position and pixel height of line above the selected window. +The returned value is a cons of the position of the first +character on the unseen line just above the scope of current +window, and the pixel height of that line." (let* ((pos0 (window-start)) (vscroll0 (window-vscroll nil t)) + (line-height nil) (pos (save-excursion (goto-char pos0) (if (bobp) (point-min) - ;; When there's an overlay string at window-start, - ;; (beginning-of-visual-line 0) stays put. - (let ((ppos (point)) - (tem (beginning-of-visual-line 0))) - (if (eq tem ppos) - (vertical-motion -1)) - (point)))))) + (vertical-motion -1) + (setq line-height (line-pixel-height)) + (point))))) ;; restore initial position (set-window-start nil pos0 t) (set-window-vscroll nil vscroll0 t) - pos)) + (cons pos line-height))) + +(defun pixel-point-at-unseen-line () + "Return the character position of line above the selected window. +The returned value is the position of the first character on the +unseen line just above the scope of current window." + (car (pixel-point-and-height-at-unseen-line))) (defun pixel-scroll-down-and-set-window-vscroll (vscroll) "Scroll down a line and set VSCROLL in pixels. @@ -354,5 +368,133 @@ Otherwise, redisplay will reset the window's vscroll." (set-window-start nil (pixel-point-at-unseen-line) t) (set-window-vscroll nil vscroll t)) +;; FIXME: This doesn't work when DELTA is larger than the height +;; of the current window, and someone should probably fix that +;; at some point. +(defun pixel-scroll-precision-scroll-down (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." + (when-let* ((posn (posn-at-point)) + (current-y (cdr (posn-x-y posn))) + (min-y (+ (frame-char-height) + (window-tab-line-height) + (window-header-line-height))) + (cursor-height (line-pixel-height)) + (window-height (window-text-height nil t)) + (next-height (save-excursion + (vertical-motion 1) + (line-pixel-height)))) + (if (and (> delta 0) + (<= cursor-height window-height)) + (while (< (- current-y min-y) delta) + (vertical-motion 1) + (setq current-y (+ current-y + (line-pixel-height))) + (when (eobp) + (signal 'end-of-buffer nil))) + (when (< (- (cdr (posn-object-width-height posn)) + (cdr (posn-object-x-y posn))) + (- window-height next-height)) + (vertical-motion 1) + (setq posn (posn-at-point) + current-y (cdr (posn-x-y posn))) + (while (< (- current-y min-y) delta) + (vertical-motion 1) + (setq current-y (+ current-y + (line-pixel-height))) + (when (eobp) + (signal 'end-of-buffer nil))))) + (let* ((desired-pos (posn-at-x-y 0 (+ delta + (window-tab-line-height) + (window-header-line-height)))) + (object (posn-object desired-pos)) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (if (or (consp object) (stringp object)) + ;; We are either on an overlay or a string, so set vscroll + ;; directly. + (set-window-vscroll nil (+ (window-vscroll nil t) + delta) + t) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t))))) + +(defun pixel-scroll-precision-scroll-up (delta) + "Scroll the current window up by DELTA pixels." + (when-let* ((max-y (- (window-text-height nil t) + (frame-char-height) + (window-tab-line-height) + (window-header-line-height))) + (posn (posn-at-point)) + (current-y (+ (cdr (posn-x-y posn)) + (line-pixel-height)))) + (while (< (- max-y current-y) delta) + (vertical-motion -1) + (setq current-y (- current-y (line-pixel-height))))) + (let ((current-vscroll (window-vscroll nil t))) + (if (<= delta current-vscroll) + (set-window-vscroll nil (- current-vscroll delta) t) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t) + (while (> delta 0) + (let ((position (pixel-point-and-height-at-unseen-line))) + (unless (cdr position) + (signal 'beginning-of-buffer nil)) + (set-window-start nil (car position) t) + ;; If the line above is taller than the window height (i.e. there's + ;; a very tall image), keep point on it. + (when (> (cdr position) (window-text-height nil t)) + (let ((vs (window-vscroll nil t))) + (goto-char (car position)) + (set-window-vscroll nil vs t))) + (setq delta (- delta (cdr position))))) + (when (< delta 0) + (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (let ((object (posn-object desired-pos))) + (if (or (consp object) (stringp object)) + (set-window-vscroll nil (+ (window-vscroll nil t) + (- delta)) + t) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))))))) + +;; FIXME: This doesn't work when there's an image above the current +;; line that is taller than the window. +(defun pixel-scroll-precision (event) + "Scroll the display vertically by pixels according to EVENT. +Move the display up or down by the pixel deltas in EVENT to +scroll the display according to the user's turning the mouse +wheel." + (interactive "e") + (let ((window (mwheel-event-window event))) + (if (and (nth 4 event) + (zerop (window-hscroll window))) + (let ((delta (round (cdr (nth 4 event))))) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event nil) + (with-selected-window window + (if (< delta 0) + (pixel-scroll-precision-scroll-down (- delta)) + (pixel-scroll-precision-scroll-up delta))))) + (mwheel-scroll event nil)))) + +;;;###autoload +(define-minor-mode pixel-scroll-precision-mode + "Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel." + :global t + :group 'mouse + :keymap pixel-scroll-precision-mode-map + (setq x-coalesce-scroll-events + (not pixel-scroll-precision-mode))) + (provide 'pixel-scroll) ;;; pixel-scroll.el ends here diff --git a/lisp/play/animate.el b/lisp/play/animate.el index 7eb1b277179..54ee9dc84eb 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -93,9 +93,17 @@ (unless (eolp) (delete-char 1)) (insert-char char 1)) -(defcustom animate-n-steps 10 +(defcustom animate-n-steps 20 "Number of steps `animate-string' will place a char before its last position." - :type 'integer) + :type 'natnum + :version "29.1") + +(defcustom animate-total-added-delay 0.5 + "Total number of seconds to wait in between steps. +This is added to the total time it takes to run `animate-string' +to ensure that the animation is not too fast to be seen." + :type 'float + :version "29.1") (defvar animation-buffer-name nil "String naming the default buffer for animations. @@ -130,7 +138,7 @@ in the current window." ;; Make sure buffer is displayed starting at the beginning. (set-window-start nil 1) ;; Display it, and wait just a little while. - (sit-for .05) + (sit-for (/ (float animate-total-added-delay) (max animate-n-steps 1))) ;; Now undo the changes we made in the buffer. (setq list-to-undo buffer-undo-list) (while list-to-undo diff --git a/lisp/play/snake.el b/lisp/play/snake.el index 29effa23460..dbdecde973d 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -160,31 +160,28 @@ and then start moving it leftwards.") ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar snake-mode-map - (let ((map (make-sparse-keymap 'snake-mode-map))) +(defvar-keymap snake-mode-map + :doc "Keymap for Snake games." + :name 'snake-mode-map + "n" #'snake-start-game + "q" #'snake-end-game + "p" #'snake-pause-game - (define-key map "n" 'snake-start-game) - (define-key map "q" 'snake-end-game) - (define-key map "p" 'snake-pause-game) + "" #'snake-move-left + "" #'snake-move-right + "" #'snake-move-up + "" #'snake-move-down - (define-key map [left] 'snake-move-left) - (define-key map [right] 'snake-move-right) - (define-key map [up] 'snake-move-up) - (define-key map [down] 'snake-move-down) + "C-b" #'snake-move-left + "C-f" #'snake-move-right + "C-p" #'snake-move-up + "C-n" #'snake-move-down) - (define-key map "\C-b" 'snake-move-left) - (define-key map "\C-f" 'snake-move-right) - (define-key map "\C-p" 'snake-move-up) - (define-key map "\C-n" 'snake-move-down) - map) - "Keymap for Snake games.") - -(defvar snake-null-map - (let ((map (make-sparse-keymap 'snake-null-map))) - (define-key map "n" 'snake-start-game) - (define-key map "q" 'quit-window) - map) - "Keymap for finished Snake games.") +(defvar-keymap snake-null-map + :doc "Keymap for finished Snake games." + :name 'snake-null-map + "n" #'snake-start-game + "q" #'quit-window) (defconst snake--menu-def '("Snake" diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index 3d6ddd5307f..693bfe49354 100644 --- a/lisp/play/tetris.el +++ b/lisp/play/tetris.el @@ -236,26 +236,24 @@ each one of its four blocks.") ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar tetris-mode-map - (let ((map (make-sparse-keymap 'tetris-mode-map))) - (define-key map "n" 'tetris-start-game) - (define-key map "q" 'tetris-end-game) - (define-key map "p" 'tetris-pause-game) +(defvar-keymap tetris-mode-map + :doc "Keymap for Tetris games." + :name 'tetris-mode-map + "n" #'tetris-start-game + "q" #'tetris-end-game + "p" #'tetris-pause-game - (define-key map " " 'tetris-move-bottom) - (define-key map [left] 'tetris-move-left) - (define-key map [right] 'tetris-move-right) - (define-key map [up] 'tetris-rotate-prev) - (define-key map [down] 'tetris-move-down) - map) - "Keymap for Tetris games.") + "SPC" #'tetris-move-bottom + "" #'tetris-move-left + "" #'tetris-move-right + "" #'tetris-rotate-prev + "" #'tetris-move-down) -(defvar tetris-null-map - (let ((map (make-sparse-keymap 'tetris-null-map))) - (define-key map "n" 'tetris-start-game) - (define-key map "q" 'quit-window) - map) - "Keymap for finished Tetris games.") +(defvar-keymap tetris-null-map + :doc "Keymap for finished Tetris games." + :name 'tetris-null-map + "n" #'tetris-start-game + "q" #'quit-window) (defconst tetris--menu-def '("Tetris" diff --git a/lisp/proced.el b/lisp/proced.el index e959e91c6e2..9e9793abece 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1333,11 +1333,12 @@ It is converted to the corresponding attribute key. This command updates the variable `proced-sort'. Prefix ARG controls sort order, see `proced-sort-interactive'." (interactive (list last-input-event (or last-prefix-arg 'no-arg)) proced-mode) - (let ((start (event-start event)) - col key) + (let* ((start (event-start event)) + (obj (posn-object start)) + col key) (save-selected-window (select-window (posn-window start)) - (setq col (+ (1- (car (posn-actual-col-row start))) + (setq col (+ (if obj (cdr obj) (posn-point start)) (window-hscroll))) (when (and (<= 0 col) (< col (length proced-header-line))) (setq key (get-text-property col 'proced-key proced-header-line)) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index a4568bd4efc..c7b01de9b98 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -6812,6 +6812,13 @@ comment at the start of cc-engine.el for more info." (defvar c-found-types nil) (make-variable-buffer-local 'c-found-types) +;; Dynamically bound variable that instructs `c-forward-type' to +;; record the ranges of types that only are found. Behaves otherwise +;; like `c-record-type-identifiers'. Also when this variable is non-nil, +;; `c-fontify-new-found-type' doesn't get called (yet) for the purported +;; type. +(defvar c-record-found-types nil) + (defsubst c-clear-found-types () ;; Clears `c-found-types'. (setq c-found-types @@ -6825,7 +6832,10 @@ comment at the start of cc-engine.el for more info." (let ((type (c-syntactic-content from to c-recognize-<>-arglists))) (unless (gethash type c-found-types) (puthash type t c-found-types) - (when (and (eq (string-match c-symbol-key type) 0) + (when (and (not c-record-found-types) ; Only call `c-fontify-new-fount-type' + ; when we haven't "bound" c-found-types + ; to itself in c-forward-<>-arglist. + (eq (string-match c-symbol-key type) 0) (eq (match-end 0) (length type))) (c-fontify-new-found-type type))))) @@ -8225,11 +8235,6 @@ multi-line strings (but not C++, for example)." (setq c-record-ref-identifiers (cons range c-record-ref-identifiers)))))) -;; Dynamically bound variable that instructs `c-forward-type' to -;; record the ranges of types that only are found. Behaves otherwise -;; like `c-record-type-identifiers'. -(defvar c-record-found-types nil) - (defmacro c-forward-keyword-prefixed-id (type) ;; Used internally in `c-forward-keyword-clause' to move forward ;; over a type (if TYPE is 'type) or a name (otherwise) which @@ -8459,6 +8464,11 @@ multi-line strings (but not C++, for example)." (c-forward-<>-arglist-recur all-types))) (progn (when (consp c-record-found-types) + (let ((cur c-record-found-types)) + (while (consp (car-safe cur)) + (c-fontify-new-found-type + (buffer-substring-no-properties (caar cur) (cdar cur))) + (setq cur (cdr cur)))) (setq c-record-type-identifiers ;; `nconc' doesn't mind that the tail of ;; `c-record-found-types' is t. @@ -9184,6 +9194,12 @@ multi-line strings (but not C++, for example)." (when (and (eq res t) (consp c-record-found-types)) + ;; Cause the confirmed types to get fontified. + (let ((cur c-record-found-types)) + (while (consp (car-safe cur)) + (c-fontify-new-found-type + (buffer-substring-no-properties (caar cur) (cdar cur))) + (setq cur (cdr cur)))) ;; Merge in the ranges of any types found by the second ;; `c-forward-type'. (setq c-record-type-identifiers diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 9355409b2af..967464ac14d 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -101,6 +101,7 @@ (cc-bytecomp-defun c-font-lock-objc-method) (cc-bytecomp-defun c-font-lock-invalid-string) (cc-bytecomp-defun c-before-context-fl-expand-region) +(cc-bytecomp-defun c-font-lock-fontify-region) ;; Note that font-lock in XEmacs doesn't expand face names as @@ -2428,6 +2429,7 @@ higher." (defun c-force-redisplay (start end) ;; Force redisplay immediately. This assumes `font-lock-support-mode' is ;; 'jit-lock-mode. Set the variable `c-re-redisplay-timer' to nil. + (save-excursion (c-font-lock-fontify-region start end)) (jit-lock-force-redisplay (copy-marker start) (copy-marker end)) (setq c-re-redisplay-timer nil)) @@ -2436,7 +2438,8 @@ higher." ;; buffer. If TYPE is currently displayed in a window, cause redisplay to ;; happen "instantaneously". These actions are done only when jit-lock-mode ;; is active. - (when (and (boundp 'font-lock-support-mode) + (when (and font-lock-mode + (boundp 'font-lock-support-mode) (eq font-lock-support-mode 'jit-lock-mode)) (c-save-buffer-state ((window-boundaries @@ -2455,7 +2458,6 @@ higher." (dolist (win-boundary window-boundaries) (when (and (< (match-beginning 0) (cdr win-boundary)) (> (match-end 0) (car win-boundary)) - (c-get-char-property (match-beginning 0) 'fontified) (not c-re-redisplay-timer)) (setq c-re-redisplay-timer (run-with-timer 0 nil #'c-force-redisplay diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 14da5880203..6e3589df7ad 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -346,12 +346,9 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; PROGRAM:SOURCE-FILE-NAME:LINENO: MESSAGE ;; which is used for non-interactive programs other than ;; compilers (e.g. the "jade:" entry in compilation.txt). - (? (| (regexp "[[:alpha:]][-[:alnum:].]+: ?") - ;; FIXME: This pattern was added for handling messages - ;; from Ruby, but it is unclear whether it is actually - ;; used since the gcc-include rule above seems to cover - ;; it. - (regexp "[ \t]+\\(?:in \\|from\\)"))) + (? (| (: alpha (+ (in ?. ?- alnum)) ":" (? " ")) + ;; Skip indentation generated by GCC's -fanalyzer. + (: (+ " ") "|"))) ;; File name group. (group-n 1 diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index d833612cd90..d7dbaa06505 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1992,7 +1992,8 @@ see the doc of that variable if you want to add names to the list." (setq set-list (delete (car set-list) set-list))) (goto-char (point-min)) (insert-before-markers - "Type `t' to select a tags table or set of tags tables:\n\n") + (substitute-command-keys + "Type \\`t' to select a tags table or set of tags tables:\n\n")) (if desired-point (goto-char desired-point)) (set-window-start (selected-window) 1 t)) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 5a31ad35087..ded3a9c463c 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -817,7 +817,7 @@ IDL has currently stepped.") Command history, searching of previous commands, command line editing are available via the comint-mode key bindings, by default - mostly on the key `C-c'. Command history is also available with + mostly on the key \\`C-c'. Command history is also available with the arrow keys UP and DOWN. 2. Completion @@ -1327,7 +1327,7 @@ See also the variable `idlwave-shell-input-mode-spells'." Characters are sent one by one, without newlines. The loop is blocking and intercepts all input events to Emacs. You can use this command to interact with the IDL command GET_KBRD. -The loop can be aborted by typing `C-g'. The loop also exits automatically +The loop can be aborted by typing \\[keyboard-quit]. The loop also exits automatically when the IDL prompt gets displayed again after the current IDL command." (interactive) @@ -1342,7 +1342,8 @@ when the IDL prompt gets displayed again after the current IDL command." (funcall errf "No IDL program seems to be waiting for input")) ;; OK, start the loop - (message "Character mode on: Sending single chars (`C-g' to exit)") + (message (substitute-command-keys + "Character mode on: Sending single chars (\\[keyboard-quit] to exit)")) (message (catch 'exit (while t diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index f11995127d4..9303f1ecb91 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -91,7 +91,7 @@ name.") (defconst js--plain-method-re (concat "^\\s-*?\\(" js--dotted-name-re "\\)\\.prototype" - "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(function\\)\\_>") + "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(\\(:?async[ \t\n]+\\)function\\)\\_>") "Regexp matching an explicit JavaScript prototype \"method\" declaration. Group 1 is a (possibly-dotted) class name, group 2 is a method name, and group 3 is the `function' keyword.") @@ -914,9 +914,10 @@ This puts point at the `function' keyword. If this is a syntactically-correct non-expression function, return the name of the function, or t if the name could not be determined. Otherwise, return nil." - (cl-assert (looking-at "\\_")) + (unless (looking-at "\\(\\_[ \t\n]+\\)?\\_") + (error "Invalid position")) (let ((name t)) - (forward-word-strictly) + (goto-char (match-end 0)) (forward-comment most-positive-fixnum) (when (eq (char-after) ?*) (forward-char) @@ -952,14 +953,17 @@ If POS is not in a function prologue, return nil." (goto-char (match-end 0)))) (skip-syntax-backward "w_") - (and (or (looking-at "\\_") - (js--re-search-backward "\\_" nil t)) - - (save-match-data (goto-char (match-beginning 0)) - (js--forward-function-decl)) - - (<= pos (point)) - (or prologue-begin (match-beginning 0)))))) + (let ((start nil)) + (and (or (looking-at "\\_") + (js--re-search-backward "\\_" nil t)) + (progn + (setq start (match-beginning 0)) + (goto-char start) + (when (looking-back "\\_[ \t\n]+" (- (point) 30)) + (setq start (match-beginning 0))) + (js--forward-function-decl)) + (<= pos (point)) + (or prologue-begin start)))))) (defun js--beginning-of-defun-raw () "Helper function for `js-beginning-of-defun'. @@ -1229,7 +1233,6 @@ LIMIT defaults to point." ;; Regular function declaration ((and (looking-at "\\_") (setq name (js--forward-function-decl))) - (when (eq name t) (setq name (js--guess-function-name orig-match-end)) (if name @@ -1241,6 +1244,11 @@ LIMIT defaults to point." (cl-assert (eq (char-after) ?{)) (forward-char) + (save-excursion + (goto-char orig-match-start) + (when (looking-back "\\_[ \t\n]+" + (- (point) 30)) + (setq orig-match-start (match-beginning 0)))) (make-js--pitem :paren-depth orig-depth :h-begin orig-match-start diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index b12b22e992e..47d8d1ce8ec 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1427,6 +1427,13 @@ marks the next defun after the ones already marked." ;;; Navigation +(defcustom python-forward-sexp-function #'python-nav-forward-sexp + "Function to use when navigating between expressions." + :version "28.1" + :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) + (const :tag "CC-mode like" nil) + function)) + (defvar python-nav-beginning-of-defun-regexp (python-rx line-start (* space) defun (+ space) (group symbol-name)) "Regexp matching class or function definition. @@ -5572,13 +5579,6 @@ By default messages are considered errors." :type '(alist :key-type (regexp) :value-type (symbol))) -(defcustom python-forward-sexp-function #'python-nav-forward-sexp - "Function to use when navigating between expressions." - :version "28.1" - :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) - (const :tag "CC-mode like" nil) - function)) - (defvar-local python--flymake-proc nil) (defun python--flymake-parse-output (source proc report-fn) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index edb98aa5fe6..ca3594d253b 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -414,19 +414,29 @@ or earlier: it can break `dired-do-find-regexp-and-replace'." :version "28.1" :package-version '(xref . "1.2.0")) -(defvar xref--history (cons nil nil) - "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.") - (make-obsolete-variable 'xref-marker-ring nil "29.1") (defun xref-set-marker-ring-length (_var _val) (declare (obsolete nil "29.1")) nil) +(defvar xref--history (cons nil nil) + "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.") + +(defun xref--push-backward (m) + "Push marker M onto the backward history stack." + (unless (equal m (caar xref--history)) + (push m (car xref--history)))) + +(defun xref--push-forward (m) + "Push marker M onto the forward history stack." + (unless (equal m (cadr xref--history)) + (push m (cdr xref--history)))) + (defun xref-push-marker-stack (&optional m) "Add point M (defaults to `point-marker') to the marker stack. The future stack is erased." - (push (or m (point-marker)) (car xref--history)) + (xref--push-backward (or m (point-marker))) (dolist (mk (cdr xref--history)) (set-marker mk nil nil)) (setcdr xref--history nil)) @@ -442,7 +452,7 @@ To undo, use \\[xref-go-forward]." (if (null (car xref--history)) (user-error "At start of xref history") (let ((marker (pop (car xref--history)))) - (push (point-marker) (cdr xref--history)) + (xref--push-forward (point-marker)) (switch-to-buffer (or (marker-buffer marker) (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) @@ -456,7 +466,7 @@ To undo, use \\[xref-go-forward]." (if (null (cdr xref--history)) (user-error "At end of xref history") (let ((marker (pop (cdr xref--history)))) - (push (point-marker) (car xref--history)) + (xref--push-backward (point-marker)) (switch-to-buffer (or (marker-buffer marker) (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) diff --git a/lisp/repeat.el b/lisp/repeat.el index ac08952eaa8..32ffb1884f3 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -402,24 +402,34 @@ See `describe-repeat-maps' for a list of all repeatable commands." (length commands) (length (delete-dups keymaps)))))) +(defvar repeat--prev-mb '(0) + "Previous minibuffer state.") + (defun repeat-post-hook () "Function run after commands to set transient keymap for repeatable keys." (let ((was-in-progress repeat-in-progress)) (setq repeat-in-progress nil) (when repeat-mode (let ((rep-map (or repeat-map + (and (symbolp this-command) + (get this-command 'repeat-map)) (and (symbolp real-this-command) (get real-this-command 'repeat-map))))) (when rep-map - (when (boundp rep-map) + (when (and (symbolp rep-map) (boundp rep-map)) (setq rep-map (symbol-value rep-map))) (let ((map (copy-keymap rep-map))) - ;; Exit when the last char is not among repeatable keys, - ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't. - (when (and (zerop (minibuffer-depth)) ; avoid remapping in prompts - (or (lookup-key map (this-command-keys-vector)) - prefix-arg)) + (when (and + ;; Detect changes in the minibuffer state to allow repetitions + ;; in the same minibuffer, but not when the minibuffer is activated + ;; in the middle of repeating sequence (bug#47566). + (or (< (minibuffer-depth) (car repeat--prev-mb)) + (eq current-minibuffer-command (cdr repeat--prev-mb))) + ;; Exit when the last char is not among repeatable keys, + ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't. + (or (lookup-key map (this-command-keys-vector)) + prefix-arg)) ;; Messaging (unless prefix-arg @@ -449,6 +459,7 @@ See `describe-repeat-maps' for a list of all repeatable commands." (funcall repeat-echo-function nil))))))))))) (setq repeat-map nil) + (setq repeat--prev-mb (cons (minibuffer-depth) current-minibuffer-command)) (when (and was-in-progress (not repeat-in-progress)) (when repeat-exit-timer (cancel-timer repeat-exit-timer) @@ -470,19 +481,20 @@ See `describe-repeat-maps' for a list of all repeatable commands." (defun repeat-echo-message (keymap) "Display available repeating keys in the echo area." - (if keymap - (let ((message (repeat-echo-message-string keymap))) - (if (current-message) - (message "%s [%s]" (current-message) message) - (message "%s" message))) - (let ((message (current-message))) - (when message - (cond - ((string-prefix-p "Repeat with " message) - (message nil)) - ((string-search " [Repeat with " message) - (message "%s" (replace-regexp-in-string - " \\[Repeat with .*\\'" "" message)))))))) + (let ((message-log-max nil)) + (if keymap + (let ((message (repeat-echo-message-string keymap))) + (if (current-message) + (message "%s [%s]" (current-message) message) + (message "%s" message))) + (let ((message (current-message))) + (when message + (cond + ((string-prefix-p "Repeat with " message) + (message nil)) + ((string-search " [Repeat with " message) + (message "%s" (replace-regexp-in-string + " \\[Repeat with .*\\'" "" message))))))))) (defvar repeat-echo-mode-line-string (propertize "[Repeating...] " 'face 'mode-line-emphasis) @@ -496,10 +508,13 @@ See `describe-repeat-maps' for a list of all repeatable commands." repeat-echo-mode-line-string))) (force-mode-line-update t))) +(declare-function help-fns--analyze-function "help-fns" (function)) + (defun describe-repeat-maps () "Describe mappings of commands repeatable by symbol property `repeat-map'. Used in `repeat-mode'." (interactive) + (require 'help-fns) (help-setup-xref (list #'describe-repeat-maps) (called-interactively-p 'interactive)) (let ((keymaps nil)) @@ -516,7 +531,14 @@ Used in `repeat-mode'." (princ (format-message "`%s' keymap is repeatable by these commands:\n" (car keymap))) (dolist (command (sort (cdr keymap) 'string-lessp)) - (princ (format-message " `%s'\n" command))) + (let* ((info (help-fns--analyze-function command)) + (map (list (symbol-value (car keymap)))) + (desc (mapconcat (lambda (key) + (format-message "`%s'" (key-description key))) + (or (where-is-internal command map) + (where-is-internal (nth 3 info) map)) + ", "))) + (princ (format-message " `%s' (bound to %s)\n" command desc)))) (princ "\n")))))) (provide 'repeat) diff --git a/lisp/replace.el b/lisp/replace.el index 5287be2c524..0e81b15a097 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2402,20 +2402,20 @@ To be added to `context-menu-functions'." ;; It would be nice to use \\[...], but there is no reasonable way ;; to make that display both SPC and Y. (defconst query-replace-help - "Type Space or `y' to replace one match, Delete or `n' to skip to next, -RET or `q' to exit, Period to replace one match and exit, -Comma to replace but not move point immediately, -C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), -C-w to delete match and recursive edit, -C-l to clear the screen, redisplay, and offer same replacement again, -! to replace all remaining matches in this buffer with no more questions, -^ to move point back to previous match, -u to undo previous replacement, -U to undo all replacements, -E to edit the replacement string. -In multi-buffer replacements type `Y' to replace all remaining + "Type \\`SPC' or \\`y' to replace one match, Delete or \\`n' to skip to next, +\\`RET' or \\`q' to exit, Period to replace one match and exit, +\\`,' to replace but not move point immediately, +\\`C-r' to enter recursive edit (\\[exit-recursive-edit] to get out again), +\\`C-w' to delete match and recursive edit, +\\`C-l' to clear the screen, redisplay, and offer same replacement again, +\\`!' to replace all remaining matches in this buffer with no more questions, +\\`^' to move point back to previous match, +\\`u' to undo previous replacement, +\\`U' to undo all replacements, +\\`E' to edit the replacement string. +In multi-buffer replacements type \\`Y' to replace all remaining matches in all remaining buffers with no more questions, -`N' to skip to the next buffer without replacing remaining matches +\\`N' to skip to the next buffer without replacing remaining matches in the current buffer." "Help message while in `query-replace'.") diff --git a/lisp/rot13.el b/lisp/rot13.el index 4e4e60fea3f..e509b22529f 100644 --- a/lisp/rot13.el +++ b/lisp/rot13.el @@ -46,29 +46,23 @@ ;;; Code: -(defvar rot13-display-table - (let ((table (make-display-table)) - (i 0)) - (while (< i 26) +(defconst rot13-display-table + (let ((table (make-display-table))) + (dotimes (i 26) (aset table (+ i ?a) (vector (+ (% (+ i 13) 26) ?a))) - (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A))) - (setq i (1+ i))) + (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A)))) table) "Char table for ROT13 display.") -(defvar rot13-translate-table - (let ((str (make-string 127 0)) - (i 0)) - (while (< i 127) - (aset str i i) - (setq i (1+ i))) - (setq i 0) - (while (< i 26) - (aset str (+ i ?a) (+ (% (+ i 13) 26) ?a)) - (aset str (+ i ?A) (+ (% (+ i 13) 26) ?A)) - (setq i (1+ i))) - str) - "String table for ROT13 translation.") +(put 'plain-char-table 'char-table-extra-slots 0) + +(defconst rot13-translate-table + (let ((table (make-char-table 'translation-table))) + (dotimes (i 26) + (aset table (+ i ?a) (+ (% (+ i 13) 26) ?a)) + (aset table (+ i ?A) (+ (% (+ i 13) 26) ?A))) + table) + "Char table for ROT13 translation.") ;;;###autoload (defun rot13 (object &optional start end) diff --git a/lisp/simple.el b/lisp/simple.el index a192c4601bc..26c3ff575e2 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -541,9 +541,9 @@ Other major modes are defined by comparison with this one." (defvar-keymap special-mode-map :suppress t "q" #'quit-window - " " #'scroll-up-command - [?\S-\ ] #'scroll-down-command - "\C-?" #'scroll-down-command + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "DEL" #'scroll-down-command "?" #'describe-mode "h" #'describe-mode ">" #'end-of-buffer @@ -8912,7 +8912,7 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally. When called interactively, the user is prompted for VARIABLE and then VALUE. The current value of VARIABLE will be put in the -minibuffer history so that it can be accessed with `M-n', which +minibuffer history so that it can be accessed with \\`M-n', which makes it easier to edit it." (interactive (let* ((default-var (variable-at-point)) diff --git a/lisp/startup.el b/lisp/startup.el index 98843e5745b..47804b211fd 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1838,11 +1838,14 @@ a face or button specification." :face 'variable-pitch "To quit a partially entered command, type " :face 'default "Control-g" :face 'variable-pitch ".\n") - (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) - "\nThis is " - (emacs-version) - "\n" - :face '(variable-pitch (:height 0.8)) + (save-restriction + (narrow-to-region (point) (point)) + (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) + "\nThis is " + (emacs-version) + "\n") + (fill-region (point-min) (point-max))) + (fancy-splash-insert :face '(variable-pitch (:height 0.8)) emacs-copyright "\n") (when auto-save-list-file-prefix @@ -2123,8 +2126,11 @@ To quit a partially entered command, type Control-g.\n") 'follow-link t) (insert "\tChange initialization settings including this screen\n") - (insert "\n" (emacs-version) - "\n" emacs-copyright)) + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n" (emacs-version) "\n") + (fill-region (point-min) (point-max))) + (insert emacs-copyright)) (defun normal-no-mouse-startup-screen () "Show a splash screen suitable for displays without mouse support." @@ -2204,7 +2210,11 @@ If you have no Meta key, you may instead type ESC followed by the character.)")) (startup--get-buffer-create-scratch))) 'follow-link t) (insert "\n") - (insert "\n" (emacs-version) "\n" emacs-copyright "\n") + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n" (emacs-version) "\n") + (fill-region (point-min) (point-max))) + (insert emacs-copyright "\n") (insert (substitute-command-keys " GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) @@ -2385,6 +2395,7 @@ A fancy display is used on graphic displays, normal otherwise." ;; and long versions of what's on command-switch-alist. (longopts (append '("--funcall" "--load" "--insert" "--kill" + "--dump-file" "--seccomp" "--directory" "--eval" "--execute" "--no-splash" "--find-file" "--visit" "--file" "--no-desktop") (mapcar (lambda (elt) (concat "-" (car elt))) @@ -2546,6 +2557,11 @@ nil default-directory" name) (error "File name omitted from `-insert' option")) (insert-file-contents (command-line-normalize-file-name tem))) + ((or (equal argi "-dump-file") + (equal argi "-seccomp")) + ;; This was processed in C. + (or argval (pop command-line-args-left))) + ((equal argi "-kill") (kill-emacs t)) diff --git a/lisp/subr.el b/lisp/subr.el index 3902251586e..78c72838f3f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -925,69 +925,6 @@ side-effects, and the argument LIST is not modified." ;;;; Keymap support. -(defun kbd-valid-p (keys) - "Say whether KEYS is a valid `kbd' sequence. -A `kbd' sequence is a string consisting of one and more key -strokes. The key strokes are separated by a space character. - -Each key stroke is either a single character, or the name of an -event, surrounded by angle brackets. In addition, any key stroke -may be preceded by one or more modifier keys. Finally, a limited -number of characters have a special shorthand syntax. - -Here's some example key sequences. - - \"f\" (the key 'f') - \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') - \"C-c o\" (a two key sequence of the keys 'c' with the control modifier - and then the key 'o') - \"H-\" (the key named \"left\" with the hyper modifier) - \"M-RET\" (the \"return\" key with a meta modifier) - \"C-M-\" (the \"space\" key with both the control and meta modifiers) - -These are the characters that have shorthand syntax: -NUL, RET, TAB, LFD, ESC, SPC, DEL. - -Modifiers have to be specified in this order: - - A-C-H-M-S-s - -which is - - Alt-Control-Hyper-Meta-Shift-super" - (declare (pure t) (side-effect-free t)) - (and (stringp keys) - (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) - (save-match-data - (catch 'exit - (let ((prefixes - "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") - (case-fold-search nil)) - (dolist (key (split-string keys " ")) - ;; Every key might have these modifiers, and they should be - ;; in this order. - (when (string-match (concat "\\`" prefixes) key) - (setq key (substring key (match-end 0)))) - (unless (or (and (= (length key) 1) - ;; Don't accept control characters as keys. - (not (< (aref key 0) ?\s)) - ;; Don't accept Meta'd characters as keys. - (or (multibyte-string-p key) - (not (<= 127 (aref key 0) 255)))) - (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) - ;; Don't allow . - (= (progn - (string-match - (concat "\\`<" prefixes) key) - (match-end 0)) - 1)) - (string-match-p - "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" - key)) - ;; Invalid. - (throw 'exit nil))) - t))))) - (defun kbd (keys) "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such @@ -1006,110 +943,15 @@ Here's some example key sequences: For an approximate inverse of this, see `key-description'." (declare (pure t) (side-effect-free t)) - ;; A pure function is expected to preserve the match data. - (save-match-data - (let ((case-fold-search nil) - (len (length keys)) ; We won't alter keys in the loop below. - (pos 0) - (res [])) - (while (and (< pos len) - (string-match "[^ \t\n\f]+" keys pos)) - (let* ((word-beg (match-beginning 0)) - (word-end (match-end 0)) - (word (substring keys word-beg len)) - (times 1) - key) - ;; Try to catch events of the form "". - (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) - (setq word (match-string 0 word) - pos (+ word-beg (match-end 0))) - (setq word (substring keys word-beg word-end) - pos word-end)) - (when (string-match "\\([0-9]+\\)\\*." word) - (setq times (string-to-number (substring word 0 (match-end 1)))) - (setq word (substring word (1+ (match-end 1))))) - (cond ((string-match "^<<.+>>$" word) - (setq key (vconcat (if (eq (key-binding [?\M-x]) - 'execute-extended-command) - [?\M-x] - (or (car (where-is-internal - 'execute-extended-command)) - [?\M-x])) - (substring word 2 -2) "\r"))) - ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) - (progn - (setq word (concat (match-string 1 word) - (match-string 3 word))) - (not (string-match - "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" - word)))) - (setq key (list (intern word)))) - ((or (equal word "REM") (string-match "^;;" word)) - (setq pos (string-match "$" keys pos))) - (t - (let ((orig-word word) (prefix 0) (bits 0)) - (while (string-match "^[ACHMsS]-." word) - (setq bits (+ bits (cdr (assq (aref word 0) - '((?A . ?\A-\^@) (?C . ?\C-\^@) - (?H . ?\H-\^@) (?M . ?\M-\^@) - (?s . ?\s-\^@) (?S . ?\S-\^@)))))) - (setq prefix (+ prefix 2)) - (setq word (substring word 2))) - (when (string-match "^\\^.$" word) - (setq bits (+ bits ?\C-\^@)) - (setq prefix (1+ prefix)) - (setq word (substring word 1))) - (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") - ("LFD" . "\n") ("TAB" . "\t") - ("ESC" . "\e") ("SPC" . " ") - ("DEL" . "\177"))))) - (when found (setq word (cdr found)))) - (when (string-match "^\\\\[0-7]+$" word) - (let ((n 0)) - (dolist (ch (cdr (string-to-list word))) - (setq n (+ (* n 8) ch -48))) - (setq word (vector n)))) - (cond ((= bits 0) - (setq key word)) - ((and (= bits ?\M-\^@) (stringp word) - (string-match "^-?[0-9]+$" word)) - (setq key (mapcar (lambda (x) (+ x bits)) - (append word nil)))) - ((/= (length word) 1) - (error "%s must prefix a single character, not %s" - (substring orig-word 0 prefix) word)) - ((and (/= (logand bits ?\C-\^@) 0) (stringp word) - ;; We used to accept . and ? here, - ;; but . is simply wrong, - ;; and C-? is not used (we use DEL instead). - (string-match "[@-_a-z]" word)) - (setq key (list (+ bits (- ?\C-\^@) - (logand (aref word 0) 31))))) - (t - (setq key (list (+ bits (aref word 0))))))))) - (when key - (dolist (_ (number-sequence 1 times)) - (setq res (vconcat res key)))))) - (when (and (>= (length res) 4) - (eq (aref res 0) ?\C-x) - (eq (aref res 1) ?\() - (eq (aref res (- (length res) 2)) ?\C-x) - (eq (aref res (- (length res) 1)) ?\))) - (setq res (apply #'vector (let ((lres (append res nil))) - ;; Remove the first and last two elements. - (setq lres (cdr (cdr lres))) - (nreverse lres) - (setq lres (cdr (cdr lres))) - (nreverse lres) - lres)))) - (if (not (memq nil (mapcar (lambda (ch) - (and (numberp ch) - (<= 0 ch 127))) - res))) - ;; Return a string. - (concat (mapcar #'identity res)) - ;; Return a vector. - res)))) + (let ((res (key-parse keys))) + (if (not (memq nil (mapcar (lambda (ch) + (and (numberp ch) + (<= 0 ch 127))) + res))) + ;; Return a string. + (concat (mapcar #'identity res)) + ;; Return a vector. + res))) (defun undefined () "Beep to tell the user this binding is undefined." @@ -1160,6 +1002,9 @@ PARENT if non-nil should be a keymap." (defun define-key-after (keymap key definition &optional after) "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is a legacy function; see `keymap-set-after' for the +recommended function to use instead. + This is like `define-key' except that the binding for KEY is placed just after the binding for the event AFTER, instead of at the beginning of the map. Note that AFTER must be an event type (like KEY), NOT a command @@ -1330,6 +1175,9 @@ Subkeymaps may be modified but are not canonicalized." (defun keyboard-translate (from to) "Translate character FROM to TO on the current terminal. +This is a legacy function; see `keymap-translate' for the +recommended function to use instead. + This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it." (or (char-table-p keyboard-translate-table) @@ -1341,6 +1189,9 @@ and then modifies one entry in it." (defun global-set-key (key command) "Give KEY a global binding as COMMAND. +This is a legacy function; see `keymap-global-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1362,6 +1213,9 @@ that you make with this function." (defun local-set-key (key command) "Give KEY a local binding as COMMAND. +This is a legacy function; see `keymap-local-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1380,12 +1234,18 @@ cases is shared with all other buffers in the same major mode." (defun global-unset-key (key) "Remove global binding of KEY. +This is a legacy function; see `keymap-global-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key globally: ") (global-set-key key nil)) (defun local-unset-key (key) "Remove local binding of KEY. +This is a legacy function; see `keymap-local-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key locally: ") (if (current-local-map) @@ -1394,6 +1254,9 @@ KEY is a string or vector representing a sequence of keystrokes." (defun local-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current local keymap only. +This is a legacy function; see `keymap-local-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. @@ -1405,6 +1268,9 @@ about this." (defun global-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current global keymap only. +This is a legacy function; see `keymap-global-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. This function's return values are the same as those of `lookup-key' @@ -1423,6 +1289,9 @@ about this." (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +This is a legacy function; see `keymap-substitute' for the +recommended function to use instead. + In other words, OLDDEF is replaced with NEWDEF wherever it appears. Alternatively, if optional fourth argument OLDMAP is specified, we redefine in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. @@ -1684,22 +1553,22 @@ nil or (STRING . POSITION)'. `posn-timestamp': The time the event occurred, in milliseconds. For more information, see Info node `(elisp)Click Events'." - (if (consp event) (nth 1 event) - ;; Use `window-point' for the case when the current buffer - ;; is temporarily switched to some other buffer (bug#50256) - (or (posn-at-point (window-point)) - (list (selected-window) (window-point) '(0 . 0) 0)))) + (or (and (consp event) (nth 1 event)) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0))) (defun event-end (event) "Return the ending position of EVENT. EVENT should be a click, drag, or key press event. See `event-start' for a description of the value returned." - (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event) - ;; Use `window-point' for the case when the current buffer - ;; is temporarily switched to some other buffer (bug#50256) - (or (posn-at-point (window-point)) - (list (selected-window) (window-point) '(0 . 0) 0)))) + (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event)) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0))) (defsubst event-click-count (event) "Return the multi-click count of EVENT, a click or drag event. @@ -3251,7 +3120,7 @@ Optional argument CHARS, if non-nil, should be a list of characters; the function will ignore any input that is not one of CHARS. Optional argument HISTORY, if non-nil, should be a symbol that specifies the history list variable to use for navigating in input -history using `M-p' and `M-n', with `RET' to select a character from +history using \\`M-p' and \\`M-n', with \\`RET' to select a character from history. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -6656,6 +6525,28 @@ not a list, return a one-element list containing OBJECT." object (list object))) +(defun define-keymap--compile (form &rest args) + ;; This compiler macro is only there for compile-time + ;; error-checking; it does not change the call in any way. + (while (and args + (keywordp (car args)) + (not (eq (car args) :menu))) + (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) + (byte-compile-warn "Invalid keyword: %s" (car args))) + (setq args (cdr args)) + (when (null args) + (byte-compile-warn "Uneven number of keywords in %S" form)) + (setq args (cdr args))) + ;; Bindings. + (while args + (let ((key (pop args))) + (when (and (stringp key) (not (key-valid-p key))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (when (null args) + (byte-compile-warn "Uneven number of key bindings in %S" form)) + (setq args (cdr args))) + form) + (defun define-keymap (&rest definitions) "Create a new keymap and define KEY/DEFEFINITION pairs as key sequences. The new keymap is returned. @@ -6683,15 +6574,13 @@ pairs. Available keywords are: command (see `define-prefix-command'). If this is the case, this symbol is returned instead of the map itself. -KEY/DEFINITION pairs are as KEY and DEF in `define-key'. KEY can +KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can also be the special symbol `:menu', in which case DEFINITION should be a MENU form as accepted by `easy-menu-define'. \(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" - (declare (indent defun)) - (define-keymap--define definitions)) - -(defun define-keymap--define (definitions) + (declare (indent defun) + (compiler-macro define-keymap--compile)) (let (full suppress parent name prefix keymap) ;; Handle keywords. (while (and definitions @@ -6735,7 +6624,7 @@ should be a MENU form as accepted by `easy-menu-define'. (let ((def (pop definitions))) (if (eq key :menu) (easy-menu-define nil keymap "" def) - (define-key keymap key def))))) + (keymap-set keymap key def))))) keymap))) (defmacro defvar-keymap (variable-name &rest defs) @@ -6763,7 +6652,7 @@ as the variable documentation string. (unless (zerop (% (length defs) 2)) (error "Uneven number of key/definition pairs: %s" defs)) `(defvar ,variable-name - (define-keymap--define (list ,@(nreverse opts) ,@defs)) + (define-keymap ,@(nreverse opts) ,@defs) ,@(and doc (list doc))))) (defmacro with-delayed-message (args &rest body) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 10f26875db5..656cb878e3e 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -91,9 +91,10 @@ (defcustom tab-bar-select-tab-modifiers '() "List of modifier keys for selecting tab-bar tabs by their numbers. Possible modifier keys are `control', `meta', `shift', `hyper', `super' and -`alt'. Pressing one of the modifiers in the list and a digit selects -the tab whose number equals the digit. Negative numbers count from -the end of the tab bar. The digit 9 selects the last (rightmost) tab. +`alt'. Pressing one of the modifiers in the list and a digit selects the +tab whose number equals the digit (see `tab-bar-select-tab'). +The digit 9 selects the last (rightmost) tab (see `tab-last'). +The digit 0 selects the most recently visited tab (see `tab-recent'). For easier selection of tabs by their numbers, consider customizing `tab-bar-tab-hints', which will show tab numbers alongside the tab name." :type '(set :tag "Tab selection modifier keys" @@ -283,7 +284,8 @@ 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 (eq (car item) 'add-tab) (nth 2 item)) + (unless (or (memq (car item) '(add-tab history-back history-forward)) + (nth 2 item)) (if (functionp (nth 1 item)) (call-interactively (nth 1 item)) (unless (eq tab-number t) @@ -297,7 +299,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 (eq (car item) 'add-tab) (functionp (nth 1 item))) + ((and (memq (car item) '(add-tab history-back history-forward)) + (functionp (nth 1 item))) (call-interactively (nth 1 item))) ((and (nth 2 item) (not (eq tab-number t))) (tab-bar-close-tab tab-number))))) @@ -979,10 +982,11 @@ on the tab bar instead." (wc-point . ,(point-marker)) (wc-bl . ,bl) (wc-bbl . ,bbl) - (wc-history-back . ,(gethash (or frame (selected-frame)) - tab-bar-history-back)) - (wc-history-forward . ,(gethash (or frame (selected-frame)) - tab-bar-history-forward)) + ,@(when tab-bar-history-mode + `((wc-history-back . ,(gethash (or frame (selected-frame)) + tab-bar-history-back)) + (wc-history-forward . ,(gethash (or frame (selected-frame)) + tab-bar-history-forward)))) ;; Copy other possible parameters ,@(mapcan (lambda (param) (unless (memq (car param) @@ -1060,11 +1064,14 @@ inherits the current tab's `explicit-name' parameter." (defun tab-bar-select-tab (&optional tab-number) "Switch to the tab by its absolute position TAB-NUMBER in the tab bar. -When this command is bound to a numeric key (with a prefix or modifier key +When this command is bound to a numeric key (with a key prefix or modifier key using `tab-bar-select-tab-modifiers'), calling it without an argument will translate its bound numeric key to the numeric argument. -TAB-NUMBER counts from 1. Negative TAB-NUMBER counts tabs from the end of -the tab bar." +Also the prefix argument TAB-NUMBER can be used to override +the numeric key, so it takes precedence over the bound digit key. +For example, `-2' will select the second tab, but `C-u 15 +-2' will select the 15th tab. TAB-NUMBER counts from 1. +Negative TAB-NUMBER counts tabs from the end of the tab bar." (interactive "P") (unless (integerp tab-number) (let ((key (event-basic-type last-command-event))) @@ -1092,7 +1099,11 @@ the tab bar." ;; its value of window-configuration is unreadable, ;; so restore its saved window-state. (cond - ((window-configuration-p wc) + ((and (window-configuration-p wc) + ;; Check for such cases as cloning a frame with tabs. + ;; When tabs were cloned to another frame, then fall back + ;; to using `window-state-put' below. + (eq (window-configuration-frame wc) (selected-frame))) (let ((wc-point (alist-get 'wc-point to-tab)) (wc-bl (seq-filter #'buffer-live-p (alist-get 'wc-bl to-tab))) (wc-bbl (seq-filter #'buffer-live-p (alist-get 'wc-bbl to-tab))) @@ -1116,19 +1127,21 @@ the tab bar." (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl)) (when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl)) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-back))) - wc-history-back) - tab-bar-history-back) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) - wc-history-forward) - tab-bar-history-forward))) + (when tab-bar-history-mode + (puthash (selected-frame) + (and (window-configuration-p (alist-get 'wc (car wc-history-back))) + wc-history-back) + tab-bar-history-back) + (puthash (selected-frame) + (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) + wc-history-forward) + tab-bar-history-forward)))) (ws (window-state-put ws nil 'safe))) - (setq tab-bar-history-omit t) + (when tab-bar-history-mode + (setq tab-bar-history-omit t)) (when from-index (setf (nth from-index tabs) from-tab)) @@ -1161,7 +1174,8 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." (defun tab-bar-switch-to-last-tab (&optional arg) "Switch to the last tab or ARGth tab from the end of the tab bar. Interactively, ARG is the prefix numeric argument; it defaults to 1, -which means the last tab on the tab bar." +which means the last tab on the tab bar. For example, `C-u 2 +-9' selects the tab before the last tab." (interactive "p") (tab-bar-select-tab (- (length (funcall tab-bar-tabs-function)) (1- (or arg 1))))) @@ -1182,7 +1196,9 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." Default values are tab names sorted by recency, so you can use \ \\\\[next-history-element] to get the name of the most recently visited tab, the second -most recent, and so on." +most recent, and so on. +When the tab with that NAME doesn't exist, create a new tab +and rename it to NAME." (interactive (let* ((recent-tabs (mapcar (lambda (tab) (alist-get 'name tab)) @@ -1190,7 +1206,11 @@ most recent, and so on." (list (completing-read (format-prompt "Switch to tab by name" (car recent-tabs)) recent-tabs nil nil nil nil recent-tabs)))) - (tab-bar-select-tab (1+ (or (tab-bar--tab-index-by-name name) 0)))) + (let ((tab-index (tab-bar--tab-index-by-name name))) + (if tab-index + (tab-bar-select-tab (1+ tab-index)) + (tab-bar-new-tab) + (tab-bar-rename-tab name)))) (defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab) @@ -1377,6 +1397,11 @@ After the tab is created, the hooks in ;; `pushnew' handles the head of tabs but not frame-parameter (tab-bar-tabs-set tabs)) + (when tab-bar-history-mode + (puthash (selected-frame) nil tab-bar-history-back) + (puthash (selected-frame) nil tab-bar-history-forward) + (setq tab-bar-history-omit t)) + (run-hook-with-args 'tab-bar-tab-post-open-functions (nth to-index tabs))) @@ -1793,30 +1818,34 @@ Interactively, prompt for GROUP-NAME." (defvar tab-bar-history-old nil "Window configuration before the current command.") -(defvar tab-bar-history-old-minibuffer-depth 0 - "Minibuffer depth before the current command.") +(defvar tab-bar-history-pre-command nil + "Command set to `this-command' by `pre-command-hook'.") + +(defvar tab-bar-history-done-command nil + "Command handled by `window-configuration-change-hook'.") (defun tab-bar--history-pre-change () - (setq tab-bar-history-old-minibuffer-depth (minibuffer-depth)) - ;; Store window-configuration before possibly entering the minibuffer. - (when (zerop tab-bar-history-old-minibuffer-depth) + ;; Reset before the command could set it + (setq tab-bar-history-omit nil) + (setq tab-bar-history-pre-command this-command) + (when (zerop (minibuffer-depth)) (setq tab-bar-history-old `((wc . ,(current-window-configuration)) (wc-point . ,(point-marker)))))) (defun tab-bar--history-change () - (when (and (not tab-bar-history-omit) - tab-bar-history-old - ;; Store window-configuration before possibly entering - ;; the minibuffer. - (zerop tab-bar-history-old-minibuffer-depth)) + (when (and (not tab-bar-history-omit) tab-bar-history-old + ;; Don't register changes performed by the same command + ;; repeated in sequence, such as incremental window resizing. + (not (eq tab-bar-history-done-command tab-bar-history-pre-command)) + (zerop (minibuffer-depth))) (puthash (selected-frame) (seq-take (cons tab-bar-history-old (gethash (selected-frame) tab-bar-history-back)) tab-bar-history-limit) - tab-bar-history-back)) - (when tab-bar-history-omit - (setq tab-bar-history-omit nil))) + tab-bar-history-back) + (setq tab-bar-history-old nil)) + (setq tab-bar-history-done-command tab-bar-history-pre-command)) (defun tab-bar-history-back () "Restore a previous window configuration used in the current tab. diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 5affae79138..af0647acf7c 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -792,7 +792,9 @@ Its effect is the same as using the `previous-buffer' command (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 (funcall tab-line-tabs-function)) + (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) @@ -816,7 +818,9 @@ Its effect is the same as using the `next-buffer' command (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 (funcall tab-line-tabs-function)) + (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) @@ -893,7 +897,14 @@ sight of the tab line." (define-minor-mode tab-line-mode "Toggle display of tab line in the windows displaying the current buffer." :lighter nil - (setq tab-line-format (when tab-line-mode '(:eval (tab-line-format))))) + (let ((default-value '(:eval (tab-line-format)))) + (if tab-line-mode + ;; Preserve the existing tab-line set outside of this mode + (unless tab-line-format + (setq tab-line-format default-value)) + ;; Reset only values set by this mode + (when (equal tab-line-format default-value) + (setq tab-line-format nil))))) (defcustom tab-line-exclude-modes '(completion-list-mode) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el new file mode 100644 index 00000000000..3c4d00f7f99 --- /dev/null +++ b/lisp/term/haiku-win.el @@ -0,0 +1,139 @@ +;;; haiku-win.el --- set up windowing on Haiku -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Support for using Haiku's BeOS derived windowing system. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(unless (featurep 'haiku) + (error "%s: Loading haiku-win without having Haiku" + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) + +(add-to-list 'display-format-alist '(".*" . haiku-win)) + +;;;; Command line argument handling. + +(defvar x-invocation-args) +(defvar x-command-line-resources) + +(defvar haiku-initialized) + +(declare-function x-open-connection "haikufns.c") +(declare-function x-handle-args "common-win") +(declare-function haiku-selection-data "haikuselect.c") +(declare-function haiku-selection-put "haikuselect.c") +(declare-function haiku-selection-targets "haikuselect.c") +(declare-function haiku-put-resource "haikufns.c") + +(defun haiku--handle-x-command-line-resources (command-line-resources) + "Handle command line X resources specified with the option `-xrm'. +The resources should be a list of strings in COMMAND-LINE-RESOURCES." + (dolist (s command-line-resources) + (let ((components (split-string s ":"))) + (when (car components) + (haiku-put-resource (car components) + (string-trim-left + (mapconcat #'identity (cdr components) ":"))))))) + +(cl-defmethod window-system-initialization (&context (window-system haiku) + &optional display) + "Set up the window system. WINDOW-SYSTEM must be HAIKU. +DISPLAY may be set to the name of a display that will be initialized." + (cl-assert (not haiku-initialized)) + + (create-default-fontset) + (when x-command-line-resources + (haiku--handle-x-command-line-resources + (split-string x-command-line-resources "\n"))) + (x-open-connection (or display "be") x-command-line-resources t) + (setq haiku-initialized t)) + +(cl-defmethod frame-creation-function (params &context (window-system haiku)) + (x-create-frame-with-faces params)) + +(cl-defmethod handle-args-function (args &context (window-system haiku)) + (x-handle-args args)) + +(defun haiku--selection-type-to-mime (type) + "Convert symbolic selection type TYPE to its MIME equivalent. +If TYPE is nil, return \"text/plain\"." + (cond + ((memq type '(TEXT COMPOUND_TEXT STRING UTF8_STRING)) "text/plain") + ((stringp type) type) + ((symbolp type) (symbol-name type)) + (t "text/plain"))) + +(cl-defmethod gui-backend-get-selection (type data-type + &context (window-system haiku)) + (if (eq data-type 'TARGETS) + (apply #'vector (mapcar #'intern + (haiku-selection-targets type))) + (haiku-selection-data type (haiku--selection-type-to-mime data-type)))) + +(cl-defmethod gui-backend-set-selection (type value + &context (window-system haiku)) + (haiku-selection-put type "text/plain" value t)) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system haiku)) + (haiku-selection-data selection "text/plain")) + +(cl-defmethod gui-backend-selection-owner-p (_ + &context (window-system haiku)) + t) + +(declare-function haiku-read-file-name "haikufns.c") + +(defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p) + "SKIP: real doc in xfns.c." + (if (eq (framep-on-display (selected-frame)) 'haiku) + (haiku-read-file-name prompt (selected-frame) + (or dir (and default_filename + (file-name-directory default_filename))) + mustmatch only_dir_p + (file-name-nondirectory default_filename)) + (error "x-file-dialog on a tty frame"))) + +(defun haiku-dnd-handle-drag-n-drop-event (event) + "Handle specified drag-n-drop EVENT." + (interactive "e") + (let* ((string (caddr event)) + (window (posn-window (event-start event)))) + (with-selected-window window + (raise-frame) + (dnd-handle-one-url window 'private (concat "file:" string))))) + +(define-key special-event-map [drag-n-drop] + 'haiku-dnd-handle-drag-n-drop-event) + +(provide 'haiku-win) +(provide 'term/haiku-win) + +;;; haiku-win.el ends here diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 1d450b50012..2a9cae29f79 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -2160,7 +2160,7 @@ The word checked is the word at the mouse position." (interactive "e") (let ((save (point))) (mouse-set-point event) - (flyspell-correct-word-before-point event save))) + (flyspell-correct-word-before-point (and (consp event) event) save))) (defun flyspell-correct-word-before-point (&optional event opoint) "Pop up a menu of possible corrections for misspelled word before point. @@ -2270,17 +2270,8 @@ If OPOINT is non-nil, restore point there after adjusting it for replacement." ;;*---------------------------------------------------------------------*/ (defun flyspell-emacs-popup (event poss word) "The Emacs popup menu." - (if (and (not event) - (display-mouse-p)) - (let* ((mouse-pos (mouse-position)) - (mouse-pos (if (nth 1 mouse-pos) - mouse-pos - (set-mouse-position (car mouse-pos) - (/ (frame-width) 2) 2) - (mouse-position)))) - (setq event (list (list (car (cdr mouse-pos)) - (1+ (cdr (cdr mouse-pos)))) - (car mouse-pos))))) + (unless event + (setq event (popup-menu-normalize-position (point)))) (let* ((corrects (flyspell-sort (car (cdr (cdr poss))) word)) (cor-menu (if (consp corrects) (mapcar (lambda (correct) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 0a3a49d868a..4087f7e5f29 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -2398,24 +2398,24 @@ Global `ispell-quit' set to start location to continue spell session." Selections are: -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame." +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame." (if (equal ispell-help-in-bufferp 'electric) (progn @@ -2428,26 +2428,28 @@ SPC: Accept word this time. ;;(if (< (window-height) 15) ;; (enlarge-window ;; (- 15 (ispell-adjusted-window-height)))) - (princ "Selections are: + (princ + (substitute-command-keys + "Selections are: -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits - the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame.") +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits + the aborted check to be completed later. +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame.")) nil))) @@ -3883,8 +3885,8 @@ Don't check spelling of message headers except the Subject field. Don't check included messages. To abort spell checking of a message region and send the message anyway, -use the `x' command. (Any subsequent regions will be checked.) -The `X' command aborts sending the message so that you can edit the buffer. +use the \\`x' command. (Any subsequent regions will be checked.) +The \\`X' command aborts sending the message so that you can edit the buffer. To spell-check whenever a message is sent, include the appropriate lines in your init file: diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index b90c21339cc..f787f5f3e56 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -148,8 +148,10 @@ No active TAGS table is required." (erase-buffer) (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") (insert - " Move point to label and type `r' to run a query-replace on the label\n" - " and its references. Type `q' to exit this buffer.\n\n") + (substitute-command-keys + " Move point to label and type \\`r' to run a query-replace on the label\n") + (substitute-command-keys + " and its references. Type \\`q' to exit this buffer.\n\n")) (insert " LABEL FILE\n") (insert " -------------------------------------------------------------\n") (use-local-map (make-sparse-keymap)) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 9d9eab4d7b5..357f7da2f9d 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -29,9 +29,7 @@ (require 'reftex) -;; START remove for XEmacs release (defvar TeX-master) -;; END remove for XEmacs release ;;;###autoload (defun reftex-index-selection-or-word (&optional arg phrase) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index d57a7678553..eedc067b868 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -392,19 +392,19 @@ that the *toc* window fills half the frame." (defcustom reftex-toc-include-file-boundaries nil "Non-nil means, include file boundaries in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `F' key." +This flag can be toggled from within the *toc* buffer with the \\`F' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-include-labels nil "Non-nil means, include labels in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `l' key." +This flag can be toggled from within the *toc* buffer with the \\`l' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-include-index-entries nil "Non-nil means, include index entries in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `i' key." +This flag can be toggled from within the *toc* buffer with the \\`i' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -422,14 +422,14 @@ changed." (defcustom reftex-toc-include-context nil "Non-nil means, include context with labels in the *toc* buffer. Context will only be shown when labels are visible as well. -This flag can be toggled from within the *toc* buffer with the `c' key." +This flag can be toggled from within the *toc* buffer with the \\`c' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-follow-mode nil "Non-nil means, point in *toc* buffer will cause other window to follow. The other window will show the corresponding part of the document. -This flag can be toggled from within the *toc* buffer with the `f' key." +This flag can be toggled from within the *toc* buffer with the \\`f' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -1627,14 +1627,14 @@ to that section." (defcustom reftex-index-include-context nil "Non-nil means, display the index definition context in the index buffer. -This flag may also be toggled from the index buffer with the `c' key." +This flag may also be toggled from the index buffer with the \\`c' key." :group 'reftex-index-support :type 'boolean) (defcustom reftex-index-follow-mode nil "Non-nil means, point in *Index* buffer will cause other window to follow. The other window will show the corresponding part of the document. -This flag can be toggled from within the *Index* buffer with the `f' key." +This flag can be toggled from within the *Index* buffer with the \\`f' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -1863,10 +1863,11 @@ of the regular expressions in this list, that file is not parsed by RefTeX." (defcustom reftex-enable-partial-scans nil "Non-nil means, re-parse only 1 file when asked to re-parse. Re-parsing is normally requested with a \\[universal-argument] prefix to many RefTeX commands, -or with the `r' key in menus. When this option is t in a multifile document, +or with the \\`r' key in menus. When this option is t in a multifile document, we will only parse the current buffer, or the file associated with the label or section heading near point in a menu. Requesting re-parsing of an entire -multifile document then requires a \\[universal-argument] \\[universal-argument] prefix or the capital `R' key +multifile document then requires a \\[universal-argument] \ +\\[universal-argument] prefix or the capital \\`R' key in menus." :group 'reftex-optimizations-for-large-documents :type 'boolean) @@ -1912,7 +1913,7 @@ when new labels in its category are added. See the variable When a new label is defined with `reftex-label', all selection buffers associated with that label category are emptied, in order to force an update upon next use. When nil, the buffers are left alone and have to be -updated by hand, with the `g' key from the label selection process. +updated by hand, with the \\`g' key from the label selection process. The value of this variable will only have any effect when `reftex-use-multiple-selection-buffers' is non-nil." :group 'reftex-optimizations-for-large-documents @@ -1964,7 +1965,7 @@ instead or as well. The variable may have one of these values: both Both cursor and mouse trigger highlighting. Changing this variable requires rebuilding the selection and *toc* buffers -to become effective (keys `g' or `r')." +to become effective (keys \\`g' or \\`r')." :group 'reftex-fontification-configurations :type '(choice (const :tag "Never" nil) diff --git a/lisp/time.el b/lisp/time.el index 8496adec228..4f302caa674 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -343,7 +343,7 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1." "Update the `display-time' info for the mode line. However, don't redisplay right now. -This is used for things like Rmail `g' that want to force an +This is used for things like Rmail \\`g' that want to force an update which can wait for the next redisplay." (let* ((now (current-time)) (time (current-time-string now)) diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 23b67ee2cab..6cc482d012a 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -368,10 +368,15 @@ It is also called if Tooltip mode is on, for text-only displays." ((equal-including-properties tooltip-help-message (current-message)) (message nil))))) +(declare-function menu-or-popup-active-p "xmenu.c" ()) + (defun tooltip-show-help (msg) "Function installed as `show-help-function'. MSG is either a help string to display, or nil to cancel the display." - (if (display-graphic-p) + (if (and (display-graphic-p) + (or (not (eq window-system 'haiku)) ;; On Haiku, there isn't a reliable way to show tooltips + ;; above menus. + (not (menu-or-popup-active-p)))) (let ((previous-help tooltip-help-message)) (setq tooltip-help-message msg) (cond ((null msg) diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 186bf35fe7e..bf985280d80 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -423,11 +423,9 @@ where ;; Handle prefix definitions specially ;; so that a mode that rebinds some subcommands ;; won't make it appear that the whole prefix is gone. - (key-fun (if (eq def-fun 'ESC-prefix) - (lookup-key global-map [27]) - (if (eq def-fun 'Control-X-prefix) - (lookup-key global-map [24]) - (key-binding key)))) + (key-fun (if (keymapp def-fun) + (lookup-key global-map key) + (key-binding key))) (where (where-is-internal (if rem-fun rem-fun def-fun))) cwhere) diff --git a/lisp/userlock.el b/lisp/userlock.el index 348ccc6f8ec..9a2d45a8468 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -39,10 +39,6 @@ (define-error 'file-locked "File is locked" 'file-error) -(defun userlock--fontify-key (key) - "Add the `help-key-binding' face to string KEY." - (propertize key 'face 'help-key-binding)) - ;;;###autoload (defun ask-user-about-lock (file opponent) "Ask user what to do when he wants to edit FILE but it is locked by OPPONENT. @@ -68,12 +64,9 @@ in any way you like." (match-string 0 opponent))) opponent)) (while (null answer) - (message "%s locked by %s: (%s, %s, %s, %s)? " - short-file short-opponent - (userlock--fontify-key "s") - (userlock--fontify-key "q") - (userlock--fontify-key "p") - (userlock--fontify-key "?")) + (message (substitute-command-keys + "%s locked by %s: (\\`s', \\`q', \\`p', \\`?'? ") + short-file short-opponent) (if noninteractive (error "Cannot resolve lock conflict in batch mode")) (let ((tem (let ((inhibit-quit t) (cursor-in-echo-area t)) @@ -88,12 +81,9 @@ in any way you like." (?? . help)))) (cond ((null answer) (beep) - (message "Please type %s, %s, or %s; or %s for help" - (userlock--fontify-key "q") - (userlock--fontify-key "s") - (userlock--fontify-key "p") - ;; FIXME: Why do we use "?" here and "C-h" below? - (userlock--fontify-key "?")) + ;; FIXME: Why do we use "?" here and "C-h" below? + (message (substitute-command-keys + "Please type \\`q', \\`s', or \\`p'; or \\`?' for help")) (sit-for 3)) ((eq (cdr answer) 'help) (ask-user-about-lock-help) @@ -106,17 +96,14 @@ in any way you like." (with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output (insert - (format + (substitute-command-keys "It has been detected that you want to modify a file that someone else has already started modifying in Emacs. -You can <%s>teal the file; the other user becomes the +You can <\\`s'>teal the file; the other user becomes the intruder if (s)he ever unmodifies the file and then changes it again. -You can <%s>roceed; you edit at your own (and the other user's) risk. -You can <%s>uit; don't modify this file." - (userlock--fontify-key "s") - (userlock--fontify-key "p") - (userlock--fontify-key "q"))) +You can <\\`p'>roceed; you edit at your own (and the other user's) risk. +You can <\\`q'>uit; don't modify this file.")) (help-mode)))) (define-error 'file-supersession nil 'file-error) @@ -169,14 +156,11 @@ The buffer in question is current when this function is called." (discard-input) (save-window-excursion (let ((prompt - (format "%s changed on disk; \ -really edit the buffer? (%s, %s, %s or %s) " - (file-name-nondirectory filename) - (userlock--fontify-key "y") - (userlock--fontify-key "n") - (userlock--fontify-key "r") - ;; FIXME: Why do we use "C-h" here and "?" above? - (userlock--fontify-key "C-h"))) + ;; FIXME: Why do we use "C-h" here and "?" above? + (format (substitute-command-keys + "%s changed on disk; \ +really edit the buffer? (\\`y', \\`n', \\`r' or \\`C-h') ") + (file-name-nondirectory filename))) (choices '(?y ?n ?r ?? ?\C-h)) answer) (when noninteractive @@ -205,22 +189,18 @@ really edit the buffer? (%s, %s, %s or %s) " (with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output (insert - (format + (substitute-command-keys "You want to modify a buffer whose disk file has changed since you last read it in or saved it with this buffer. -If you say %s to go ahead and modify this buffer, +If you say \\`y' to go ahead and modify this buffer, you risk ruining the work of whoever rewrote the file. -If you say %s to revert, the contents of the buffer are refreshed +If you say \\`r' to revert, the contents of the buffer are refreshed from the file on disk. -If you say %s, the change you started to make will be aborted. +If you say \\`n', the change you started to make will be aborted. -Usually, you should type %s to get the latest version of the -file, then make the change again." - (userlock--fontify-key "y") - (userlock--fontify-key "r") - (userlock--fontify-key "n") - (userlock--fontify-key "r"))) +Usually, you should type \\`r' to get the latest version of the +file, then make the change again.")) (help-mode)))) ;;;###autoload diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 86b62eb1ce6..7886cc1eae2 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -40,8 +40,8 @@ "p" #'previous-line "N" #'cvs-status-next "P" #'cvs-status-prev - ["M-n"] #'cvs-status-next - ["M-p"] #'cvs-status-prev + "M-n" #'cvs-status-next + "M-p" #'cvs-status-prev "t" #'cvs-status-cvstrees "T" #'cvs-status-trees ">" #'cvs-mode-checkout) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index e68aa2257d2..8f83aa580e4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -169,49 +169,49 @@ and hunk-based syntax highlighting otherwise as a fallback." "N" #'diff-file-next "p" #'diff-hunk-prev "P" #'diff-file-prev - ["TAB"] #'diff-hunk-next - [backtab] #'diff-hunk-prev + "TAB" #'diff-hunk-next + "" #'diff-hunk-prev "k" #'diff-hunk-kill "K" #'diff-file-kill "}" #'diff-file-next ; From compilation-minor-mode. "{" #'diff-file-prev - ["RET"] #'diff-goto-source - [mouse-2] #'diff-goto-source + "RET" #'diff-goto-source + "" #'diff-goto-source "W" #'widen "o" #'diff-goto-source ; other-window "A" #'diff-ediff-patch "r" #'diff-restrict-view "R" #'diff-reverse-direction - [remap undo] #'diff-undo) + " " #'diff-undo) (defvar-keymap diff-mode-map :doc "Keymap for `diff-mode'. See also `diff-mode-shared-map'." - ["ESC"] (let ((map (define-keymap :parent diff-mode-shared-map))) - ;; We want to inherit most bindings from - ;; `diff-mode-shared-map', but not all since they may hide - ;; useful `M-' global bindings when editing. - (dolist (key '("A" "r" "R" "g" "q" "W" "z")) - (define-key map key nil)) - map) + "ESC" (let ((map (define-keymap :parent diff-mode-shared-map))) + ;; We want to inherit most bindings from + ;; `diff-mode-shared-map', but not all since they may hide + ;; useful `M-' global bindings when editing. + (dolist (key '("A" "r" "R" "g" "q" "W" "z")) + (keymap-set map key nil)) + map) ;; From compilation-minor-mode. - ["C-c C-c"] #'diff-goto-source + "C-c C-c" #'diff-goto-source ;; By analogy with the global C-x 4 a binding. - ["C-x 4 A"] #'diff-add-change-log-entries-other-window + "C-x 4 A" #'diff-add-change-log-entries-other-window ;; Misc operations. - ["C-c C-a"] #'diff-apply-hunk - ["C-c C-e"] #'diff-ediff-patch - ["C-c C-n"] #'diff-restrict-view - ["C-c C-s"] #'diff-split-hunk - ["C-c C-t"] #'diff-test-hunk - ["C-c C-r"] #'diff-reverse-direction - ["C-c C-u"] #'diff-context->unified + "C-c C-a" #'diff-apply-hunk + "C-c C-e" #'diff-ediff-patch + "C-c C-n" #'diff-restrict-view + "C-c C-s" #'diff-split-hunk + "C-c C-t" #'diff-test-hunk + "C-c C-r" #'diff-reverse-direction + "C-c C-u" #'diff-context->unified ;; `d' because it duplicates the context :-( --Stef - ["C-c C-d"] #'diff-unified->context - ["C-c C-w"] #'diff-ignore-whitespace-hunk + "C-c C-d" #'diff-unified->context + "C-c C-w" #'diff-ignore-whitespace-hunk ;; `l' because it "refreshes" the hunk like C-l refreshes the screen - ["C-c C-l"] #'diff-refresh-hunk - ["C-c C-b"] #'diff-refine-hunk ;No reason for `b' :-( - ["C-c C-f"] #'next-error-follow-minor-mode) + "C-c C-l" #'diff-refresh-hunk + "C-c C-b" #'diff-refine-hunk ;No reason for `b' :-( + "C-c C-f" #'next-error-follow-minor-mode) (easy-menu-define diff-mode-menu diff-mode-map "Menu for `diff-mode'." @@ -266,11 +266,12 @@ and hunk-based syntax highlighting otherwise as a fallback." (defcustom diff-minor-mode-prefix "\C-c=" "Prefix key for `diff-minor-mode' commands." - :type '(choice (string "\e") (string "C-c=") string)) + :type '(choice (string "ESC") + (string "\C-c=") string)) (defvar-keymap diff-minor-mode-map :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'." - diff-minor-mode-prefix diff-mode-shared-map) + (key-description diff-minor-mode-prefix) diff-mode-shared-map) (define-minor-mode diff-auto-refine-mode "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode). diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el index 0450cd7f23b..48e1f15f05c 100644 --- a/lisp/vc/ediff-help.el +++ b/lisp/vc/ediff-help.el @@ -227,7 +227,9 @@ the value of this variable and the variables `ediff-help-message-*' in ((string= cmd "s") (re-search-forward "^['`‘]s['’]")) ((string= cmd "+") (re-search-forward "^['`‘]\\+['’]")) ((string= cmd "=") (re-search-forward "^['`‘]=['’]")) - (t (user-error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer"))) + (t (user-error (substitute-command-keys + "Undocumented command! Type \\`G' in Ediff Control \ +Panel to drop a note to the Ediff maintainer")))) ) ; let case-fold-search )) diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index eaccb7a98c7..4b352bd34fc 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -615,8 +615,8 @@ Actually, Ediff restores the scope of visibility that existed at startup.") (defcustom ediff-keep-variants t "Nil means prompt to remove unmodified buffers A/B/C at session end. -Supplying a prefix argument to the quit command `q' temporarily reverses the -meaning of this variable." +Supplying a prefix argument to the quit command \\`q' temporarily +reverses the meaning of this variable." :type 'boolean :group 'ediff) diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index 7622cf4c196..a03c6a5ed7e 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -415,7 +415,9 @@ other files, enter `/dev/null'. (with-output-to-temp-buffer ediff-msg-buffer (ediff-with-current-buffer standard-output (fundamental-mode)) - (princ (format-message " + (with-current-buffer standard-output + (insert (format-message + (substitute-command-keys " Ediff has inferred that %s %s @@ -423,10 +425,10 @@ are two possible targets for applying the patch. Both files seem to be plausible alternatives. Please advise: - Type `y' to use %s as the target; - Type `n' to use %s as the target. -" - file1 file2 file1 file2))) + Type \\`y' to use %s as the target; + Type \\`n' to use %s as the target. +") + file1 file2 file1 file2)))) (setcar session-file-object (if (y-or-n-p (format "Use %s ? " file1)) (progn @@ -823,7 +825,8 @@ you can still examine the changes via M-x ediff-files" ediff-patch-diagnostics patch-diagnostics)) (bury-buffer patch-diagnostics) - (message "Type `P', if you need to see patch diagnostics") + (message (substitute-command-keys + "Type \\`P', if you need to see patch diagnostics")) ctl-buf)) (defun ediff-multi-patch-internal (patch-buf &optional startup-hooks) diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el index 97c84ae5a18..cb4c8d93052 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -1558,7 +1558,9 @@ With optional NODE, goes to that node." (info "ediff") (if node (Info-goto-node node) - (message "Type `i' to search for a specific topic")) + (message (substitute-command-keys + (concat "Type \\\\[Info-index] to" + " search for a specific topic")))) (raise-frame)) (error (beep 1) (with-output-to-temp-buffer ediff-msg-buffer diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index c8d089e4113..6e3f302263b 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -55,18 +55,18 @@ (define-obsolete-variable-alias 'vc-log-entry-mode 'log-edit-mode-map "28.1") (defvar-keymap log-edit-mode-map - (kbd "C-c C-c") #'log-edit-done - (kbd "C-c C-a") #'log-edit-insert-changelog - (kbd "C-c C-w") #'log-edit-generate-changelog-from-diff - (kbd "C-c C-d") #'log-edit-show-diff - (kbd "C-c C-f") #'log-edit-show-files - (kbd "C-c C-k") #'log-edit-kill-buffer - (kbd "C-a") #'log-edit-beginning-of-line - (kbd "M-n") #'log-edit-next-comment - (kbd "M-p") #'log-edit-previous-comment - (kbd "M-r") #'log-edit-comment-search-backward - (kbd "M-s") #'log-edit-comment-search-forward - (kbd "C-c ?") #'log-edit-mode-help) + "C-c C-c" #'log-edit-done + "C-c C-a" #'log-edit-insert-changelog + "C-c C-w" #'log-edit-generate-changelog-from-diff + "C-c C-d" #'log-edit-show-diff + "C-c C-f" #'log-edit-show-files + "C-c C-k" #'log-edit-kill-buffer + "C-a" #'log-edit-beginning-of-line + "M-n" #'log-edit-next-comment + "M-p" #'log-edit-previous-comment + "M-r" #'log-edit-comment-search-backward + "M-s" #'log-edit-comment-search-forward + "C-c ?" #'log-edit-mode-help) (easy-menu-define log-edit-menu log-edit-mode-map "Menu used for `log-edit-mode'." diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 2c78000e38b..d45c1696a2f 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -123,7 +123,7 @@ :prefix "log-view-") (defvar-keymap log-view-mode-map - (kbd "RET") #'log-view-toggle-entry-display + "RET" #'log-view-toggle-entry-display "m" #'log-view-toggle-mark-entry "e" #'log-view-modify-change-comment "d" #'log-view-diff @@ -133,12 +133,12 @@ "f" #'log-view-find-revision "n" #'log-view-msg-next "p" #'log-view-msg-prev - (kbd "TAB") #'log-view-msg-next - (kbd "") #'log-view-msg-prev + "TAB" #'log-view-msg-next + "" #'log-view-msg-prev "N" #'log-view-file-next "P" #'log-view-file-prev - (kbd "M-n") #'log-view-file-next - (kbd "M-p") #'log-view-file-prev) + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) (easy-menu-define log-view-mode-menu log-view-mode-map "Log-View Display Menu." diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index 2daa42fbf8f..2d7b8cb2ef7 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -164,33 +164,33 @@ "z" #'kill-this-buffer "F" #'cvs-mode-set-flags "!" #'cvs-mode-force-command - ["C-c C-c"] #'cvs-mode-kill-process + "C-c C-c" #'cvs-mode-kill-process ;; marking "m" #'cvs-mode-mark "M" #'cvs-mode-mark-all-files "S" #'cvs-mode-mark-on-state "u" #'cvs-mode-unmark - ["DEL"] #'cvs-mode-unmark-up + "DEL" #'cvs-mode-unmark-up "%" #'cvs-mode-mark-matching-files "T" #'cvs-mode-toggle-marks - ["M-DEL"] #'cvs-mode-unmark-all-files + "M-DEL" #'cvs-mode-unmark-all-files ;; navigation keys - " " #'cvs-mode-next-line + "SPC" #'cvs-mode-next-line "n" #'cvs-mode-next-line "p" #'cvs-mode-previous-line - "\t" #'cvs-mode-next-line - [backtab] #'cvs-mode-previous-line + "TAB" #'cvs-mode-next-line + "" #'cvs-mode-previous-line ;; M- keys are usually those that operate on modules - ["M-c"] #'cvs-checkout - ["M-e"] #'cvs-examine + "M-c" #'cvs-checkout + "M-e" #'cvs-examine "g" #'cvs-mode-revert-buffer - ["M-u"] #'cvs-update - ["M-s"] #'cvs-status + "M-u" #'cvs-update + "M-s" #'cvs-status ;; diff commands "=" #'cvs-mode-diff "d" cvs-mode-diff-map ;; keys that operate on individual files - ["C-k"] #'cvs-mode-acknowledge + "C-k" #'cvs-mode-acknowledge "A" #'cvs-mode-add-change-log-entry-other-window "C" #'cvs-mode-commit-setup "O" #'cvs-mode-update @@ -202,7 +202,7 @@ "c" #'cvs-mode-commit "e" #'cvs-mode-examine "f" #'cvs-mode-find-file - ["RET"] #'cvs-mode-find-file + "RET" #'cvs-mode-find-file "i" #'cvs-mode-ignore "l" #'cvs-mode-log "o" #'cvs-mode-find-file-other-window @@ -214,12 +214,12 @@ ;; cvstree bindings "+" #'cvs-mode-tree ;; mouse bindings - [mouse-2] #'cvs-mode-find-file - [follow-link] (lambda (pos) + "" #'cvs-mode-find-file + "" (lambda (pos) (eq (get-char-property pos 'face) 'cvs-filename)) - [(down-mouse-3)] #'cvs-menu + "" #'cvs-menu ;; dired-like bindings - "\C-o" #'cvs-mode-display-file) + "C-o" #'cvs-mode-display-file) (easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." '("CVS" @@ -269,10 +269,10 @@ (defcustom cvs-minor-mode-prefix "\C-xc" "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." :type 'string - :group 'pcl-cvs) + :group 'pcl-cvs) (defvar-keymap cvs-minor-mode-map - cvs-minor-mode-prefix 'cvs-mode-map + (key-description cvs-minor-mode-prefix) 'cvs-mode-map "e" '(menu-item nil cvs-mode-edit-log :filter (lambda (x) (and (derived-mode-p 'log-view-mode) x)))) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 2cc5ee739fd..6c1b8cc95b3 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -156,7 +156,7 @@ Used in `smerge-diff-base-upper' and related functions." "E" #'smerge-ediff "C" #'smerge-combine-with-next "R" #'smerge-refine - ["C-m"] #'smerge-keep-current + "C-m" #'smerge-keep-current "=" (define-keymap :name "Diff" "<" (cons "base-upper" #'smerge-diff-base-upper) ">" (cons "base-lower" #'smerge-diff-base-lower) @@ -165,12 +165,12 @@ Used in `smerge-diff-base-upper' and related functions." (defcustom smerge-command-prefix "\C-c^" "Prefix for `smerge-mode' commands." :type '(choice (const :tag "ESC" "\e") - (const :tag "C-c ^" "\C-c^" ) + (const :tag "C-c ^" "\C-c^") (const :tag "none" "") string)) (defvar-keymap smerge-mode-map - smerge-command-prefix smerge-basic-map) + (key-description smerge-command-prefix) smerge-basic-map) (defvar-local smerge-check-cache nil) (defun smerge-check (n) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 6f921ac2a04..c8954472245 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -309,10 +309,11 @@ to the CVS command." (defun vc-cvs-responsible-p (file) "Return non-nil if CVS thinks it is responsible for FILE." - (file-directory-p (expand-file-name "CVS" - (if (file-directory-p file) - file - (file-name-directory file))))) + (let ((dir (if (file-directory-p file) + file + (file-name-directory file)))) + (and (file-directory-p (expand-file-name "CVS" dir)) + (file-name-directory (expand-file-name "CVS" dir))))) (defun vc-cvs-could-register (file) "Return non-nil if FILE could be registered in CVS. diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el index fe631ee09a7..49a8af10e78 100644 --- a/lisp/vc/vc-dav.el +++ b/lisp/vc/vc-dav.el @@ -136,10 +136,10 @@ It should return a status of either 0 (no differences found), or "Find the version control state of all files in DIR in a fast way." ) -(defun vc-dav-responsible-p (_url) +(defun vc-dav-responsible-p (url) "Return non-nil if DAV considers itself `responsible' for URL." ;; Check for DAV support on the web server. - t) + (and t url)) ;;; Unimplemented functions ;; diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2d35061b269..4b6cd930744 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1688,7 +1688,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (let ((stash (completing-read prompt (split-string - (or (vc-git--run-command-string nil "stash" "list") "") "\n") + (or (vc-git--run-command-string nil "stash" "list") "") "\n" t) nil :require-match nil 'vc-git-stash-read-history))) (if (string-equal stash "") (user-error "Not a stash") @@ -1733,12 +1733,11 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-stash-list () (when-let ((out (vc-git--run-command-string nil "stash" "list"))) - (delete - "" - (split-string - (replace-regexp-in-string - "^stash@" " " out) - "\n")))) + (split-string + (replace-regexp-in-string + "^stash@" " " out) + "\n" + t))) (defun vc-git-stash-get-at-point (point) (save-excursion diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index e38469ba9f0..2422e99d3da 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -290,10 +290,11 @@ to the RCS command." (defun vc-rcs-responsible-p (file) "Return non-nil if RCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-rcs-master-templates - (file-directory-p (expand-file-name "RCS" - (if (file-directory-p file) - file - (file-name-directory file))))) + (let ((dir (if (file-directory-p file) + file + (file-name-directory file)))) + (and (file-directory-p (expand-file-name "RCS" dir)) + (file-name-directory (expand-file-name "RCS" dir))))) (defun vc-rcs-receive-file (file rev) "Implementation of receive-file for RCS." diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index bcbb87eba8e..4b56fbf28ef 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -214,9 +214,13 @@ to the SCCS command." (defun vc-sccs-responsible-p (file) "Return non-nil if SCCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-sccs-master-templates - (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) - (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "") - (file-name-nondirectory file))))) + (or (and (file-directory-p + (expand-file-name "SCCS" (file-name-directory file))) + (file-name-directory file)) + (let ((dir (vc-sccs-search-project-dir (or (file-name-directory file) "") + (file-name-nondirectory file)))) + (and (stringp dir) + dir)))) (defun vc-sccs-checkin (files comment &optional rev) "SCCS-specific version of `vc-backend-checkin'." diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 4b56f1b795c..64f752f248d 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -944,8 +944,10 @@ use." bk) (dolist (backend vc-handled-backends) (when (not (vc-call-backend backend 'registered file)) - (let* ((path (vc-call-backend backend 'responsible-p file)) - (len (length path))) + (let* ((dir-name (vc-call-backend backend 'responsible-p file)) + (len (and dir-name + (length (file-name-split + (expand-file-name dir-name)))))) (when (and len (> len max)) (setq max len bk backend))))) (when bk @@ -977,7 +979,7 @@ use." (message "arg %s" arg) (and (file-directory-p arg) (string-prefix-p (expand-file-name arg) def-dir))))))) - (let ((default-directory repo-dir)) + (let ((default-directory repo-dir)) (vc-call-backend bk 'create-repo)) (throw 'found bk)))) diff --git a/lisp/vcursor.el b/lisp/vcursor.el index e219dc2d1a5..df65db39e38 100644 --- a/lisp/vcursor.el +++ b/lisp/vcursor.el @@ -788,9 +788,9 @@ out how much to copy." (vcursor-check) (with-current-buffer (overlay-buffer vcursor-overlay) - (let ((start (goto-char (overlay-start vcursor-overlay)))) - (- (progn (apply func args) (point)) start))) - ) + (save-excursion + (let ((start (goto-char (overlay-start vcursor-overlay)))) + (- (progn (apply func args) (point)) start))))) ;; Make sure the virtual cursor is active. Unless arg is non-nil, ;; report an error if it is not. diff --git a/lisp/version.el b/lisp/version.el index 3a3093fdd4a..5d0a1ae37dc 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -53,6 +53,8 @@ developing Emacs.") (defvar ns-version-string) (defvar cairo-version-string) +(declare-function haiku-get-version-string "haikufns.c") + (defun emacs-version (&optional here) "Return string describing the version of Emacs that is running. If optional argument HERE is non-nil, insert string at point. @@ -71,6 +73,8 @@ to the system configuration; look at `system-configuration' instead." ((featurep 'x-toolkit) ", X toolkit") ((featurep 'ns) (format ", NS %s" ns-version-string)) + ((featurep 'haiku) + (format ", Haiku %s" (haiku-get-version-string))) (t "")) (if (featurep 'cairo) (format ", cairo version %s" cairo-version-string) diff --git a/lisp/windmove.el b/lisp/windmove.el index 658e59af198..8904f5cbf70 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -700,7 +700,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or a single modifier. If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings are directly bound to the arrow keys. -Default value of PREFIX is `C-x' and MODIFIERS is `shift'." +Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'." (interactive) (unless prefix (setq prefix '(?\C-x))) (when (eq prefix 'none) (setq prefix nil)) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 485d995f418..cf4396fec2d 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -55,6 +55,11 @@ (declare-function delete-xwidget-view "xwidget.c" (xwidget-view)) (declare-function get-buffer-xwidgets "xwidget.c" (buffer)) (declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit)) +(declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-set-cookie-storage-file "xwidget.c" (xwidget file)) +(declare-function xwidget-live-p "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-stop-loading "xwidget.c" (xwidget)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." @@ -74,12 +79,9 @@ This returns the result of `make-xwidget'." (defun xwidget-at (pos) "Return xwidget at POS." - ;; TODO this function is a bit tedious because the C layer isn't well - ;; protected yet and xwidgetp apparently doesn't work yet. (let* ((disp (get-text-property pos 'display)) - (xw (car (cdr (cdr disp))))) - ;;(if (xwidgetp xw) xw nil) - (if (equal 'xwidget (car disp)) xw))) + (xw (car (cdr (cdr disp))))) + (when (xwidget-live-p xw) xw))) @@ -105,8 +107,13 @@ It can use the following special constructs: :type 'string :version "29.1") -(defvar-local xwidget-webkit--title "" - "The title of the WebKit widget, used for the header line.") +(defcustom xwidget-webkit-cookie-file nil + "The name of the file where `xwidget-webkit-browse-url' will store cookies. +They will be stored as plain text in Mozilla \"cookies.txt\" +format. If nil, do not store cookies. You must kill all xwidget-webkit +buffers for this setting to take effect after setting it to nil." + :type '(choice (const :tag "Do not store cookies" nil) file) + :version "29.1") ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) @@ -149,6 +156,12 @@ in `split-window-right' with a new xwidget webkit session." (defvar xwidget-webkit--input-method-events nil "Internal variable used to store input method events.") +(defvar-local xwidget-webkit--loading-p nil + "Whether or not a page is being loaded.") + +(defvar-local xwidget-webkit--progress-update-timer nil + "Timer that updates the display of page load progress in the header line.") + (defun xwidget-webkit-pass-command-event-with-input-method () "Handle a `with-input-method' event." (interactive) @@ -186,7 +199,6 @@ for the actual events that will be sent." (define-key map "b" 'xwidget-webkit-back) (define-key map "f" 'xwidget-webkit-forward) (define-key map "r" 'xwidget-webkit-reload) - (define-key map "t" (lambda () (interactive) (message "o"))) ;FIXME: ?!? (define-key map "\C-m" 'xwidget-webkit-insert-string) (define-key map "w" 'xwidget-webkit-current-url) (define-key map "+" 'xwidget-webkit-zoom-in) @@ -194,6 +206,7 @@ for the actual events that will be sent." (define-key map "e" 'xwidget-webkit-edit-mode) (define-key map "\C-r" 'xwidget-webkit-isearch-mode) (define-key map "\C-s" 'xwidget-webkit-isearch-mode) + (define-key map "H" 'xwidget-webkit-browse-history) ;;similar to image mode bindings (define-key map (kbd "SPC") 'xwidget-webkit-scroll-up) @@ -228,6 +241,7 @@ for the actual events that will be sent." ["Back" xwidget-webkit-back t] ["Forward" xwidget-webkit-forward t] ["Reload" xwidget-webkit-reload t] + ["History" xwidget-webkit-browse-history t] ["Insert String" xwidget-webkit-insert-string :active t :help "Insert a string into the currently active field"] @@ -243,11 +257,17 @@ for the actual events that will be sent." :help "Save the browser's selection in the kill ring"] ["Incremental Search" xwidget-webkit-isearch-mode :active (not xwidget-webkit-isearch-mode) - :help "Perform incremental search inside the WebKit widget"])) + :help "Perform incremental search inside the WebKit widget"] + ["Stop Loading" xwidget-webkit-stop + :active xwidget-webkit--loading-p])) (defvar xwidget-webkit-tool-bar-map (let ((map (make-sparse-keymap))) (prog1 map + (tool-bar-local-item-from-menu 'xwidget-webkit-stop + "cancel" + map + xwidget-webkit-mode-map) (tool-bar-local-item-from-menu 'xwidget-webkit-back "left-arrow" map @@ -359,10 +379,13 @@ If N is omitted or nil, scroll backwards by one char." (xwidget-webkit-current-session) "window.scrollTo(pageXOffset, window.document.body.scrollHeight);")) -;; The xwidget event needs to go into a higher level handler -;; since the xwidget can generate an event even if it's offscreen. -;; TODO this needs to use callbacks and consider different xwidget event types. -(define-key (current-global-map) [xwidget-event] #'xwidget-event-handler) +;; The xwidget event needs to go in the special map. To receive +;; xwidget events, you should place a callback in the property list of +;; the xwidget, instead of handling these events manually. +;; +;; See `xwidget-webkit-new-session' for an example of how to do this. +(define-key special-event-map [xwidget-event] #'xwidget-event-handler) + (defun xwidget-log (&rest msg) "Log MSG to a buffer." (let ((buf (get-buffer-create " *xwidget-log*"))) @@ -381,6 +404,11 @@ If N is omitted or nil, scroll backwards by one char." (when xwidget-callback (funcall xwidget-callback xwidget xwidget-event-type)))) +(defun xwidget-webkit--update-progress-timer-function (xwidget) + "Force an update of the header line of XWIDGET's buffer." + (with-current-buffer (xwidget-buffer xwidget) + (force-mode-line-update))) + (defun xwidget-webkit-callback (xwidget xwidget-event-type) "Callback for xwidgets. XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." @@ -390,6 +418,20 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (cond ((eq xwidget-event-type 'load-changed) (let ((title (xwidget-webkit-title xwidget)) (uri (xwidget-webkit-uri xwidget))) + (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (revert-buffer))) + (with-current-buffer (xwidget-buffer xwidget) + (if (string-equal (nth 3 last-input-event) + "load-finished") + (progn + (setq xwidget-webkit--loading-p nil) + (cancel-timer xwidget-webkit--progress-update-timer)) + (unless xwidget-webkit--loading-p + (setq xwidget-webkit--loading-p t + xwidget-webkit--progress-update-timer + (run-at-time 0.5 0.5 #'xwidget-webkit--update-progress-timer-function + xwidget))))) ;; This funciton will be called multi times, so only ;; change buffer name when the load actually completes ;; this can limit buffer-name flicker in mode-line. @@ -397,7 +439,6 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." "load-finished") (> (length title) 0)) (with-current-buffer (xwidget-buffer xwidget) - (setq xwidget-webkit--title title) (force-mode-line-update) (xwidget-log "webkit finished loading: %s" title) ;; Do not adjust webkit size to window here, the @@ -441,7 +482,17 @@ If non-nil, plugins are enabled. Otherwise, disabled." (setq-local tool-bar-map xwidget-webkit-tool-bar-map) (setq-local bookmark-make-record-function #'xwidget-webkit-bookmark-make-record) - (setq-local header-line-format 'xwidget-webkit--title) + (setq-local header-line-format + (list "WebKit: " + '(:eval + (xwidget-webkit-title (xwidget-webkit-current-session))) + '(:eval + (when xwidget-webkit--loading-p + (let ((session (xwidget-webkit-current-session))) + (format " [%d%%%%]" + (* 100 + (xwidget-webkit-estimated-load-progress + session)))))))) ;; Keep track of [vh]scroll when switching buffers (image-mode-setup-winprops)) @@ -517,6 +568,10 @@ The latter might be nil." (let ((size (xwidget-size-request xw))) (xwidget-resize xw (car size) (cadr size)))) +(defun xwidget-webkit-stop () + "Stop trying to load the current page." + (interactive) + (xwidget-webkit-stop-loading (xwidget-webkit-current-session))) (defvar xwidget-webkit-activeelement-js" function findactiveelement(doc){ @@ -759,7 +814,11 @@ For example, use this to display an anchor." (xwidget-window-inside-pixel-width (selected-window)) (xwidget-window-inside-pixel-height (selected-window)) nil current-session))) + (when xwidget-webkit-cookie-file + (xwidget-webkit-set-cookie-storage-file + xw (expand-file-name xwidget-webkit-cookie-file))) (xwidget-put xw 'callback callback) + (xwidget-put xw 'display-callback #'xwidget-webkit-display-callback) (xwidget-webkit-mode) (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) @@ -775,22 +834,33 @@ Return the buffer." (callback #'xwidget-webkit-callback) (buffer (get-buffer-create bufname))) (with-current-buffer buffer + (setq xwidget-webkit-last-session-buffer buffer) (save-excursion (erase-buffer) (insert ".") (put-text-property (point-min) (point-max) 'display (list 'xwidget :xwidget xwidget))) (xwidget-put xwidget 'callback callback) + (xwidget-put xwidget 'display-callback + #'xwidget-webkit-display-callback) (set-xwidget-buffer xwidget buffer) (xwidget-webkit-mode)) buffer)) (defun xwidget-webkit-display-event (event) - "Import the xwidget inside EVENT and display it." + "Trigger display callback for EVENT." (interactive "e") - (display-buffer (xwidget-webkit-import-widget (nth 1 event)))) + (let ((xwidget (cadr event)) + (source (caddr event))) + (when (xwidget-get source 'display-callback) + (funcall (xwidget-get source 'display-callback) + xwidget source)))) -(global-set-key [xwidget-display-event] 'xwidget-webkit-display-event) +(defun xwidget-webkit-display-callback (xwidget _source) + "Import XWIDGET and display it." + (display-buffer (xwidget-webkit-import-widget xwidget))) + +(define-key special-event-map [xwidget-display-event] 'xwidget-webkit-display-event) (defun xwidget-webkit-goto-url (url) "Goto URL with xwidget webkit." @@ -821,6 +891,15 @@ Return the buffer." (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) (message "URL: %s" (kill-new (or url ""))))) +(defun xwidget-webkit-browse-history () + "Display a buffer containing the history of page loads." + (interactive) + (setq xwidget-webkit-last-session-buffer (current-buffer)) + (let ((buffer (get-buffer-create "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (xwidget-webkit-history-mode)) + (display-buffer buffer))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xwidget-webkit-get-selection (proc) "Get the webkit selection and pass it to PROC." @@ -911,8 +990,8 @@ WebKit widget. The query will be set to the contents of (xwidget-webkit-current-session) t xwidget-webkit-isearch--is-reverse t)) (let ((message-log-max nil)) - (message (concat (propertize "Search contents: " 'face 'minibuffer-prompt) - xwidget-webkit-isearch--string)))) + (message "%s" (concat (propertize "Search contents: " 'face 'minibuffer-prompt) + xwidget-webkit-isearch--string)))) (defun xwidget-webkit-isearch-erasing-char (count) "Erase the last COUNT characters of the current query." @@ -1059,6 +1138,66 @@ Press \\\\[xwidget-webkit-isearch-exit] to exit (concat xwidget-webkit-isearch--string (current-kill 0))) (xwidget-webkit-isearch--update)) + +(defvar-local xwidget-webkit-history--session nil + "The xwidget this history buffer controls.") + +(define-button-type 'xwidget-webkit-history 'action #'xwidget-webkit-history-select-item) + +(defun xwidget-webkit-history--insert-item (item) + "Insert specified ITEM into the current buffer." + (let ((idx (car item)) + (title (cadr item)) + (uri (caddr item))) + (push (list idx (vector (list (number-to-string idx) + :type 'xwidget-webkit-history) + (list title :type 'xwidget-webkit-history) + (list uri :type 'xwidget-webkit-history))) + tabulated-list-entries))) + +(defun xwidget-webkit-history-select-item (pos) + "Navigate to the history item underneath POS." + (interactive "P") + (let ((id (tabulated-list-get-id pos))) + (xwidget-webkit-goto-history xwidget-webkit-history--session id)) + (xwidget-webkit-history-reload)) + +(defun xwidget-webkit-history-reload (&rest ignored) + "Reload the current history buffer." + (interactive) + (setq tabulated-list-entries nil) + (let* ((back-forward-list + (xwidget-webkit-back-forward-list xwidget-webkit-history--session)) + (back-list (car back-forward-list)) + (here (cadr back-forward-list)) + (forward-list (caddr back-forward-list))) + (mapc #'xwidget-webkit-history--insert-item (nreverse forward-list)) + (xwidget-webkit-history--insert-item here) + (mapc #'xwidget-webkit-history--insert-item back-list) + (tabulated-list-print t nil) + (goto-char (point-min)) + (let ((position (line-beginning-position (1+ (length back-list))))) + (goto-char position) + (setq-local overlay-arrow-position (make-marker)) + (set-marker overlay-arrow-position position)))) + +(define-derived-mode xwidget-webkit-history-mode tabulated-list-mode + "Xwidget Webkit History" + "Major mode for browsing the history of an Xwidget Webkit buffer. +Each line describes an entry in history." + (setq truncate-lines t) + (setq buffer-read-only t) + (setq tabulated-list-format [("Index" 10 nil) + ("Title" 50 nil) + ("URL" 100 nil)]) + (setq tabulated-list-entries nil) + (setq xwidget-webkit-history--session (xwidget-webkit-current-session)) + (xwidget-webkit-history-reload) + (setq-local revert-buffer-function #'xwidget-webkit-history-reload) + (tabulated-list-init-header)) + +(define-key xwidget-webkit-history-mode-map (kbd "RET") + #'xwidget-webkit-history-select-item) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar xwidget-view-list) ; xwidget.c diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index cc73d9aa498..a0a10d13db5 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -157,6 +157,9 @@ xlwMenuResources[] = offset(menu.cursor_shape), XtRString, (XtPointer)"right_ptr"}, {XtNhorizontal, XtCHorizontal, XtRInt, sizeof(int), offset(menu.horizontal), XtRImmediate, (XtPointer)True}, + {XtNborderThickness, XtCBorderThickness, XtRDimension, + sizeof (Dimension), offset (menu.border_thickness), + XtRImmediate, (XtPointer)1} }; #undef offset @@ -635,9 +638,24 @@ draw_shadow_rectangle (XlwMenuWidget mw, Display *dpy = XtDisplay (mw); GC top_gc = !erase_p ? mw->menu.shadow_top_gc : mw->menu.background_gc; GC bottom_gc = !erase_p ? mw->menu.shadow_bottom_gc : mw->menu.background_gc; - int thickness = mw->menu.shadow_thickness; + int thickness = !x && !y ? mw->menu.border_thickness : mw->menu.shadow_thickness; XPoint points [4]; + if (!erase_p && width == height && width == toggle_button_width (mw)) + { + points [0].x = x; + points [0].y = y; + points [1].x = x + width; + points [1].y = y; + points [2].x = x + width; + points [2].y = y + height; + points [3].x = x; + points [3].y = y + height; + XFillPolygon (dpy, window, + down_p ? mw->menu.button_gc : mw->menu.inactive_button_gc, + points, 4, Convex, CoordModeOrigin); + } + if (!erase_p && down_p) { GC temp; @@ -701,6 +719,21 @@ draw_shadow_rhombus (XlwMenuWidget mw, int thickness = mw->menu.shadow_thickness; XPoint points [4]; + if (!erase_p && width == height && width == radio_button_width (mw)) + { + points [0].x = x; + points [0].y = y + width / 2; + points [1].x = x + height / 2; + points [1].y = y + width; + points [2].x = x + height; + points [2].y = y + width / 2; + points [3].x = x + height / 2; + points [3].y = y; + XFillPolygon (dpy, window, + down_p ? mw->menu.button_gc : mw->menu.inactive_button_gc, + points, 4, Convex, CoordModeOrigin); + } + if (!erase_p && down_p) { GC temp; @@ -1624,7 +1657,6 @@ make_drawing_gcs (XlwMenuWidget mw) #define BRIGHTNESS(color) (((color) & 0xff) + (((color) >> 8) & 0xff) + (((color) >> 16) & 0xff)) /* Allocate color for disabled menu-items. */ - mw->menu.disabled_foreground = mw->menu.foreground; if (BRIGHTNESS(mw->menu.foreground) < BRIGHTNESS(mw->core.background_pixel)) scale = 2.3; else diff --git a/lwlib/xlwmenu.h b/lwlib/xlwmenu.h index 9143edba9a2..89e548bc8da 100644 --- a/lwlib/xlwmenu.h +++ b/lwlib/xlwmenu.h @@ -56,6 +56,8 @@ along with GNU Emacs. If not, see . */ #define XtCResizeToPreferred "ResizeToPreferred" #define XtNallowResize "allowResize" #define XtCAllowResize "AllowResize" +#define XtNborderThickness "borderThickness" +#define XtCBorderThickness "BorderThickness" /* Motif-compatible resource names */ #define XmNshadowThickness "shadowThickness" diff --git a/lwlib/xlwmenuP.h b/lwlib/xlwmenuP.h index fc77ec4bfd1..bb37b0dee2f 100644 --- a/lwlib/xlwmenuP.h +++ b/lwlib/xlwmenuP.h @@ -75,6 +75,7 @@ typedef struct _XlwMenu_part Dimension vertical_spacing; Dimension arrow_spacing; Dimension shadow_thickness; + Dimension border_thickness; Pixel top_shadow_color; Pixel bottom_shadow_color; Pixmap top_shadow_pixmap; diff --git a/src/Makefile.in b/src/Makefile.in index d646001ccea..1a67d399497 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -34,6 +34,7 @@ top_builddir = @top_builddir@ abs_top_srcdir=@abs_top_srcdir@ VPATH = $(srcdir) CC = @CC@ +CXX = @CXX@ CFLAGS = @CFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ @@ -258,6 +259,9 @@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@ XFIXES_LIBS = @XFIXES_LIBS@ XFIXES_CFLAGS = @XFIXES_CFLAGS@ +XINPUT_LIBS = @XINPUT_LIBS@ +XINPUT_CFLAGS = @XINPUT_CFLAGS@ + XDBE_LIBS = @XDBE_LIBS@ XDBE_CFLAGS = @XDBE_CFLAGS@ @@ -346,10 +350,17 @@ BUILD_DETAILS = @BUILD_DETAILS@ UNEXEC_OBJ = @UNEXEC_OBJ@ +HAIKU_OBJ = @HAIKU_OBJ@ +HAIKU_CXX_OBJ = @HAIKU_CXX_OBJ@ +HAIKU_LIBS = @HAIKU_LIBS@ +HAIKU_CFLAGS = @HAIKU_CFLAGS@ + DUMPING=@DUMPING@ CHECK_STRUCTS = @CHECK_STRUCTS@ HAVE_PDUMPER = @HAVE_PDUMPER@ +HAVE_BE_APP = @HAVE_BE_APP@ + ## ARM Macs require that all code have a valid signature. Since pdump ## invalidates the signature, we must re-sign to fix it. DO_CODESIGN=$(patsubst aarch64-apple-darwin%,yes,@configuration@) @@ -367,6 +378,9 @@ endif # Flags that might be in WARN_CFLAGS but are not valid for Objective C. NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd +# Ditto, but for C++. +NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \ + -Wstrict-prototypes -Wno-override-init # -Demacs makes some files produce the correct version for use in Emacs. # MYCPPFLAGS is for by-hand Emacs-specific overrides, e.g., @@ -377,22 +391,26 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \ $(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(LIBGCCJIT_CFLAGS) $(DBUS_CFLAGS) \ $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \ - $(WEBKIT_CFLAGS) $(WEBP_CFLAGS) $(LCMS2_CFLAGS) \ + $(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) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ - $(WERROR_CFLAGS) + $(WERROR_CFLAGS) $(HAIKU_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \ $(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \ $(GNU_OBJC_CFLAGS) +ALL_CXX_CFLAGS = $(EMACS_CFLAGS) \ + $(filter-out $(NON_CXX_CFLAGS),$(WARN_CFLAGS)) $(CXXFLAGS) -.SUFFIXES: .m +.SUFFIXES: .m .cc .c.o: $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $(PROFILING_CFLAGS) $< .m.o: $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_OBJC_CFLAGS) $(PROFILING_CFLAGS) $< +.cc.o: + $(AM_V_CXX)$(CXX) -c $(CPPFLAGS) $(ALL_CXX_CFLAGS) $(PROFILING_CFLAGS) $< ## lastfile must follow all files whose initialized data areas should ## be dumped as pure by dump-emacs. @@ -413,9 +431,11 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ profiler.o decompress.o \ thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ - $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(PGTK_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) -obj = $(base_obj) $(NS_OBJC_OBJ) + $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) \ + $(HAIKU_OBJ) $(PGTK_OBJ) +doc_obj = $(base_obj) $(NS_OBJC_OBJ) +obj = $(doc_obj) $(HAIKU_CXX_OBJ) ## Object files used on some machine or other. ## These go in the DOC file on all machines in case they are needed. @@ -429,7 +449,8 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \ w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \ w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ - xsettings.o xgselect.o termcap.o hbfont.o + xsettings.o xgselect.o termcap.o hbfont.o \ + haikuterm.o haikufns.o haikumenu.o haikufont.o ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. GMALLOC_OBJ=@GMALLOC_OBJ@ @@ -455,7 +476,11 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) # Must be first, before dep inclusion! +ifneq ($(HAVE_BE_APP),yes) all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) +else +all: Emacs Emacs.pdmp $(OTHER_FILES) +endif ifeq ($(HAVE_NATIVE_COMP):$(NATIVE_DISABLED),yes:) all: ../native-lisp endif @@ -527,7 +552,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) + $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, @@ -584,6 +609,18 @@ else rm -f $@ && cp -f temacs$(EXEEXT) $@ endif +## On Haiku, also produce a binary named Emacs with the appropriate +## icon set. + +ifeq ($(HAVE_BE_APP),yes) +Emacs: emacs$(EXEEXT) + cp -f emacs$(EXEEXT) $@ + $(AM_V_GEN) $(libsrc)/be-resources \ + $(etc)/images/icons/hicolor/32x32/apps/emacs.png $@ +Emacs.pdmp: $(pdmp) + $(AM_V_GEN) cp -f $(pdmp) $@ +endif + ifeq ($(DUMPING),pdumper) $(pdmp): emacs$(EXEEXT) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ @@ -602,11 +639,11 @@ endif ## for the first time, this prevents any variation between configurations ## in the contents of the DOC file. ## -$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(obj) $(lisp) +$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(lisp) $(AM_V_GEN)$(MKDIR_P) $(etc) $(AM_V_at)rm -f $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -d $(srcdir) \ - $(SOME_MACHINE_OBJECTS) $(obj) > $(etc)/DOC + $(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \ $(shortlisp) @@ -624,7 +661,7 @@ buildobj.h: Makefile GLOBAL_SOURCES = $(base_obj:.o=.c) $(NS_OBJC_OBJ:.o=.m) gl-stamp: $(libsrc)/make-docfile$(EXEEXT) $(GLOBAL_SOURCES) - $(AM_V_GLOBALS)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) > globals.tmp + $(AM_V_GLOBALS)$(libsrc)/make-docfile -d $(srcdir) -g $(doc_obj) > globals.tmp $(AM_V_at)$(top_srcdir)/build-aux/move-if-change globals.tmp globals.h $(AM_V_at)echo timestamp > $@ @@ -649,9 +686,15 @@ endif ## to start if Vinstallation_directory has the wrong value. temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ $(charsets) $(charscript) ${emoji-zwj} $(MAKE_PDUMPER_FINGERPRINT) - $(AM_V_CCLD)$(CC) -o $@.tmp \ +ifeq ($(HAVE_BE_APP),yes) + $(AM_V_CXXLD)$(CXX) -o $@.tmp \ $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ + $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lstdc++ +else + $(AM_V_CCLD)$(CC) -o $@.tmp \ + $(ALL_CFLAGS) $(CXXFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) +endif ifeq ($(HAVE_PDUMPER),yes) $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp ifeq ($(DO_CODESIGN),yes) @@ -736,6 +779,7 @@ ${ETAGS}: FORCE # to be built before we can get TAGS. ctagsfiles1 = $(filter-out ${srcdir}/macuvs.h, $(wildcard ${srcdir}/*.[hc])) ctagsfiles2 = $(wildcard ${srcdir}/*.m) +ctagsfiles3 = $(wildcard ${srcdir}/*.cc) ## In out-of-tree builds, TAGS are generated in the build dir, like ## other non-bootstrap build products (see Bug#31744). @@ -750,7 +794,8 @@ TAGS: ${ETAGS} $(ctagsfiles1) $(ctagsfiles2) $(ctagsfiles1) \ --regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"\([^"]+\)"/\1/' \ --regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"[^"]+",[ ]\([A-Za-z0-9_]+\)/\1/' \ - $(ctagsfiles2) + $(ctagsfiles2) \ + $(ctagsfiles3) ## Arrange to make tags tables for ../lisp and ../lwlib, ## which the above TAGS file for the C files includes by reference. diff --git a/src/alloc.c b/src/alloc.c index 22e3e8e2a1b..24dc07b3696 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6152,6 +6152,10 @@ garbage_collect (void) xg_mark_data (); #endif +#ifdef HAVE_HAIKU + mark_haiku_display (); +#endif + #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif diff --git a/src/atimer.c b/src/atimer.c index 9bde9c2446f..df35603f324 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -309,24 +309,29 @@ set_alarm (void) struct itimerspec ispec; ispec.it_value = atimers->expiration; ispec.it_interval.tv_sec = ispec.it_interval.tv_nsec = 0; + if (alarm_timer_ok + && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0) + exit = true; + + /* Don't start both timerfd and POSIX timers on Cygwin; this + causes a slowdown (bug#51734). Prefer POSIX timers + because the timerfd notifications aren't delivered while + Emacs is busy, which prevents things like the hourglass + pointer from being displayed reliably (bug#19776). */ +# ifdef CYGWIN + if (exit) + return; +# endif + # ifdef HAVE_TIMERFD - if (timerfd_settime (timerfd, TFD_TIMER_ABSTIME, &ispec, 0) == 0) + if (0 <= timerfd + && timerfd_settime (timerfd, TFD_TIMER_ABSTIME, &ispec, 0) == 0) { add_timer_wait_descriptor (timerfd); exit = true; } # endif -# ifdef CYGWIN - /* Don't start both timerfd and alarms on Cygwin; this - causes a slowdown (bug#51734). */ - if (exit) - return; -# endif - if (alarm_timer_ok - && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0) - exit = true; - if (exit) return; } diff --git a/src/coding.c b/src/coding.c index 02dccf5bdb0..f8004d202e5 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9454,8 +9454,9 @@ code_convert_region (Lisp_Object start, Lisp_Object end, DEFUN ("decode-coding-region", Fdecode_coding_region, Sdecode_coding_region, 3, 4, "r\nzCoding system: ", - doc: /* Decode the current region from the specified coding system. -Interactively, prompt for the coding system to decode the region. + doc: /* Decode the current region using the specified coding system. +Interactively, prompt for the coding system to decode the region, and +replace the region with the decoded text. \"Decoding\" means transforming bytes into readable text (characters). If, for instance, you have a region that contains data that represents @@ -9485,7 +9486,9 @@ not fully specified.) */) DEFUN ("encode-coding-region", Fencode_coding_region, Sencode_coding_region, 3, 4, "r\nzCoding system: ", - doc: /* Encode the current region by specified coding system. + doc: /* Encode the current region using th 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. What's meant by \"encoding\" is transforming textual data (characters) into bytes. If, for instance, you have a region that contains the diff --git a/src/dispextern.h b/src/dispextern.h index ef4d7d915f6..0f316a2eaf9 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -140,6 +140,13 @@ typedef Emacs_Pixmap Emacs_Pix_Context; typedef struct pgtk_display_info Display_Info; typedef Emacs_Pixmap XImagePtr; typedef XImagePtr XImagePtr_or_DC; +#endif /* HAVE_PGTK */ + +#ifdef HAVE_HAIKU +#include "haikugui.h" +typedef struct haiku_display_info Display_Info; +typedef Emacs_Pixmap Emacs_Pix_Container; +typedef Emacs_Pixmap Emacs_Pix_Context; #endif #ifdef HAVE_WINDOW_SYSTEM @@ -1481,21 +1488,23 @@ struct glyph_string compared against minibuf_window (if SELW doesn't match), and SCRW which is compared against minibuf_selected_window (if MBW matches). */ -#define CURRENT_MODE_LINE_FACE_ID_3(SELW, MBW, SCRW) \ +#define CURRENT_MODE_LINE_ACTIVE_FACE_ID_3(SELW, MBW, SCRW) \ ((!mode_line_in_non_selected_windows \ || (SELW) == XWINDOW (selected_window) \ || (minibuf_level > 0 \ && !NILP (minibuf_selected_window) \ && (MBW) == XWINDOW (minibuf_window) \ && (SCRW) == XWINDOW (minibuf_selected_window))) \ - ? MODE_LINE_FACE_ID \ + ? MODE_LINE_ACTIVE_FACE_ID \ : MODE_LINE_INACTIVE_FACE_ID) /* Return the desired face id for the mode line of window W. */ -#define CURRENT_MODE_LINE_FACE_ID(W) \ - (CURRENT_MODE_LINE_FACE_ID_3((W), XWINDOW (selected_window), (W))) +#define CURRENT_MODE_LINE_ACTIVE_FACE_ID(W) \ + (CURRENT_MODE_LINE_ACTIVE_FACE_ID_3((W), \ + XWINDOW (selected_window), \ + (W))) /* Return the current height of the mode line of window W. If not known from W->mode_line_height, look at W's current glyph matrix, or return @@ -1508,7 +1517,7 @@ struct glyph_string = (MATRIX_MODE_LINE_HEIGHT ((W)->current_matrix) \ ? MATRIX_MODE_LINE_HEIGHT ((W)->current_matrix) \ : estimate_mode_line_height \ - (XFRAME ((W)->frame), CURRENT_MODE_LINE_FACE_ID (W))))) + (XFRAME ((W)->frame), CURRENT_MODE_LINE_ACTIVE_FACE_ID (W))))) /* Return the current height of the header line of window W. If not known from W->header_line_height, look at W's current glyph matrix, or return @@ -1822,7 +1831,7 @@ face_tty_specified_color (unsigned long color) enum face_id { DEFAULT_FACE_ID, - MODE_LINE_FACE_ID, + MODE_LINE_ACTIVE_FACE_ID, MODE_LINE_INACTIVE_FACE_ID, TOOL_BAR_FACE_ID, FRINGE_FACE_ID, @@ -1840,6 +1849,7 @@ enum face_id CHILD_FRAME_BORDER_FACE_ID, TAB_BAR_FACE_ID, TAB_LINE_FACE_ID, + MODE_LINE_FACE_ID, BASIC_FACE_ID_SENTINEL }; @@ -2549,7 +2559,8 @@ struct it enum line_wrap_method line_wrap; /* The ID of the default face to use. One of DEFAULT_FACE_ID, - MODE_LINE_FACE_ID, etc, depending on what we are displaying. */ + MODE_LINE_ACTIVE_FACE_ID, etc, depending on what we are + displaying. */ int base_face_id; /* If `what' == IT_CHARACTER, the character and the length in bytes @@ -2750,6 +2761,12 @@ struct it /* For iterating over bidirectional text. */ struct bidi_it bidi_it; bidi_dir_t paragraph_embedding; + + /* For handling the :min-width property. The object is the text + property we're testing the `eq' of (nil if none), and the integer + is the x position of the start of the run of glyphs. */ + Lisp_Object min_width_property; + int min_width_start; }; @@ -3022,7 +3039,7 @@ struct redisplay_interface #ifdef HAVE_WINDOW_SYSTEM # if (defined USE_CAIRO || defined HAVE_XRENDER \ - || defined HAVE_NS || defined HAVE_NTGUI) + || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU) # define HAVE_NATIVE_TRANSFORMS # endif @@ -3061,6 +3078,14 @@ struct image #ifdef HAVE_NTGUI XFORM xform; #endif +#ifdef HAVE_HAIKU + /* Non-zero if the image has not yet been transformed for display. */ + int have_be_transforms_p; + + double be_rotate; + double be_scale_x; + double be_scale_y; +#endif /* Colors allocated for this image, if any. Allocated via xmalloc. */ unsigned long *colors; @@ -3500,7 +3525,8 @@ bool valid_image_p (Lisp_Object); void prepare_image_for_display (struct frame *, struct image *); ptrdiff_t lookup_image (struct frame *, Lisp_Object, int); -#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS +#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS \ + || defined HAVE_HAIKU #define RGB_PIXEL_COLOR unsigned long #endif diff --git a/src/dispnew.c b/src/dispnew.c index 92d9eb1f700..4faa7a7777b 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -1034,7 +1034,7 @@ copy_row_except_pointers (struct glyph_row *to, struct glyph_row *from) { enum { off = offsetof (struct glyph_row, x) }; - memcpy (&to->x, &from->x, sizeof *to - off); + memcpy ((char *) to + off, (char *) from + off, sizeof *to - off); } @@ -6146,7 +6146,7 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) wrong_type_argument (Qnumberp, timeout); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) gobble_input (); #endif @@ -6454,13 +6454,18 @@ init_display_interactive (void) #endif #ifdef HAVE_PGTK - if (!inhibit_window_system -#ifndef CANNOT_DUMP - && initialized -#endif - ) + if (!inhibit_window_system && !will_dump_p ()) { Vinitial_window_system = Qpgtk; + Vwindow_system_version = make_fixnum (3); + return; + } +#endif + +#ifdef HAVE_HAIKU + if (!inhibit_window_system && !will_dump_p ()) + { + Vinitial_window_system = Qhaiku; Vwindow_system_version = make_fixnum (1); return; } diff --git a/src/editfns.c b/src/editfns.c index c8219decb06..5c9c34dc352 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -4265,9 +4265,6 @@ ring. */) enough to use as the temporary storage? That would avoid an allocation... interesting. Later, don't fool with it now. */ - /* Working without memmove, for portability (sigh), so must be - careful of overlapping subsections of the array... */ - if (end1 == start2) /* adjacent regions */ { modify_text (start1, end2); diff --git a/src/emacs.c b/src/emacs.c index adac8fc38ab..28b55d74f5a 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -109,6 +109,10 @@ along with GNU Emacs. If not, see . */ #include "getpagesize.h" #include "gnutls.h" +#ifdef HAVE_HAIKU +#include +#endif + #ifdef PROFILING # include extern void moncontrol (int mode); @@ -261,7 +265,7 @@ Initialization options:\n\ #endif #if SECCOMP_USABLE "\ ---sandbox=FILE read Seccomp BPF filter from FILE\n\ +--seccomp=FILE read Seccomp BPF filter from FILE\n\ " #endif "\ @@ -1352,6 +1356,39 @@ main (int argc, char **argv) init_standard_fds (); atexit (close_output_streams); + /* Command-line argument processing. + + The arguments in the argv[] array are sorted in the descending + order of their priority as defined in the standard_args[] array + below. Then the sorted arguments are processed from the highest + to the lowest priority. Each command-line argument that is + recognized by 'main', if found in argv[], causes skip_args to be + incremented, effectively removing the processed argument from the + command line. + + Then init_cmdargs is called, and conses a list of the unprocessed + command-line arguments, as strings, in 'command-line-args'. It + ignores all the arguments up to the one indexed by skip_args, as + those were already processed. + + The arguments in 'command-line-args' are further processed by + startup.el, functions 'command-line' and 'command-line-1'. The + first of them handles the arguments which need to be processed + before loading the user init file and initializing the + window-system. The second one processes the arguments that are + related to the GUI system, like -font, -geometry, and -title, and + then processes the rest of arguments whose priority is below + those that are related to the GUI system. The arguments + porcessed by 'command-line' are removed from 'command-line-args'; + the arguments processed by 'command-line-1' aren't, they are only + removed from 'command-line-args-left'. + + 'command-line-1' emits an error message for any argument it + doesn't recognize, so any command-line arguments processed in C + below whose priority is below the GUI system related switches + should be explicitly recognized, ignored, and removed from + 'command-line-args-left' in 'command-line-1'. */ + sort_args (argc, argv); argc = 0; while (argv[argc]) argc++; @@ -2218,7 +2255,18 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_pgtkim (); syms_of_fontset (); syms_of_xsettings (); +#endif /* HAVE_PGTK */ +#ifdef HAVE_HAIKU + syms_of_haikuterm (); + syms_of_haikufns (); + syms_of_haikumenu (); + syms_of_haikufont (); + syms_of_haikuselect (); +#ifdef HAVE_NATIVE_IMAGE_API + syms_of_haikuimage (); #endif + syms_of_fontset (); +#endif /* HAVE_HAIKU */ syms_of_gnutls (); @@ -2274,6 +2322,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #if defined WINDOWSNT || defined HAVE_NTGUI globals_of_w32select (); #endif + +#ifdef HAVE_HAIKU + init_haiku_select (); +#endif } init_charset (); @@ -2327,6 +2379,17 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Unless next switch is -nl, load "loadup.el" first thing. */ if (! no_loadup) Vtop_level = list2 (Qload, build_string ("loadup.el")); + +#ifdef HAVE_NATIVE_COMP + /* If we are going to load stuff in a non-initialized Emacs, + update the value of native-comp-eln-load-path, so that the + *.eln files will be found if they are there. */ + if (!NILP (Vtop_level) && !temacs) + Vnative_comp_eln_load_path = + Fcons (Fexpand_file_name (XCAR (Vnative_comp_eln_load_path), + Vinvocation_directory), + Qnil); +#endif } /* Set up for profiling. This is known to work on FreeBSD, @@ -2741,6 +2804,9 @@ shut_down_emacs (int sig, Lisp_Object stuff) /* Don't update display from now on. */ Vinhibit_redisplay = Qt; +#ifdef HAVE_HAIKU + be_app_quit (); +#endif /* If we are controlling the terminal, reset terminal modes. */ #ifndef DOS_NT pid_t tpgrp = tcgetpgrp (STDIN_FILENO); @@ -2750,6 +2816,10 @@ shut_down_emacs (int sig, Lisp_Object stuff) if (sig && sig != SIGTERM) { static char const fmt[] = "Fatal error %d: %n%s\n"; +#ifdef HAVE_HAIKU + if (haiku_debug_on_fatal_error) + debugger ("Fatal error in Emacs"); +#endif char buf[max ((sizeof fmt - sizeof "%d%n%s\n" + INT_STRLEN_BOUND (int) + 1), min (PIPE_BUF, MAX_ALLOCA))]; @@ -3242,6 +3312,7 @@ Special values: `ms-dos' compiled as an MS-DOS application. `windows-nt' compiled as a native W32 application. `cygwin' compiled using the Cygwin library. + `haiku' compiled for a Haiku system. Anything else (in Emacs 26, the possibilities are: aix, berkeley-unix, hpux, usg-unix-v) indicates some sort of Unix system. */); Vsystem_type = intern_c_string (SYSTEM_TYPE); diff --git a/src/fileio.c b/src/fileio.c index a7b1649fae8..859b30564aa 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -3827,20 +3827,17 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, Lisp_Object car = XCAR (window_markers); Lisp_Object marker = XCAR (car); Lisp_Object oldpos = XCDR (car); - ptrdiff_t newpos; if (MARKERP (marker) && FIXNUMP (oldpos) && XFIXNUM (oldpos) > same_at_start - && XFIXNUM (oldpos) < same_at_end) + && XFIXNUM (oldpos) <= same_at_end) { ptrdiff_t oldsize = same_at_end - same_at_start; ptrdiff_t newsize = inserted; double growth = newsize / (double)oldsize; - newpos = same_at_start - + growth * (XFIXNUM (oldpos) - same_at_start); + ptrdiff_t newpos + = same_at_start + growth * (XFIXNUM (oldpos) - same_at_start); + Fset_marker (marker, make_fixnum (newpos), Qnil); } - else - newpos = XFIXNUM (oldpos); - Fset_marker (marker, make_fixnum (newpos), Qnil); } } @@ -6193,7 +6190,7 @@ before any other event (mouse or keypress) is handled. */) (void) { #if (defined USE_GTK || defined USE_MOTIF \ - || defined HAVE_NS || defined HAVE_NTGUI) + || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU) if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) && use_dialog_box && use_file_dialog diff --git a/src/filelock.c b/src/filelock.c index cc185d96cdf..c12776246bd 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -65,7 +65,7 @@ along with GNU Emacs. If not, see . */ #define BOOT_TIME_FILE "/var/run/random-seed" #endif -#if !defined WTMP_FILE && !defined WINDOWSNT +#if !defined WTMP_FILE && !defined WINDOWSNT && defined BOOT_TIME #define WTMP_FILE "/var/log/wtmp" #endif diff --git a/src/floatfns.c b/src/floatfns.c index aadae4fd9d6..f52dae47193 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -347,6 +347,21 @@ int double_integer_scale (double d) { int exponent = ilogb (d); +#ifdef HAIKU + /* On Haiku, the values returned by ilogb are nonsensical when + confronted with tiny numbers, inf, or NaN, which breaks the trick + used by code on other platforms, so we have to test for each case + manually, and return the appropriate value. */ + if (exponent == FP_ILOGB0) + { + if (isnan (d)) + return (DBL_MANT_DIG - DBL_MIN_EXP) + 2; + if (isinf (d)) + return (DBL_MANT_DIG - DBL_MIN_EXP) + 1; + + return (DBL_MANT_DIG - DBL_MIN_EXP); + } +#endif return (DBL_MIN_EXP - 1 <= exponent && exponent < INT_MAX ? DBL_MANT_DIG - 1 - exponent : (DBL_MANT_DIG - DBL_MIN_EXP diff --git a/src/font.c b/src/font.c index 205e9d214c0..fa831f28615 100644 --- a/src/font.c +++ b/src/font.c @@ -60,6 +60,8 @@ struct table_entry const char *names[6]; }; +/* The following tables should be in sync with 'custom-face-attributes'. */ + /* Table of weight numeric values and their names. This table must be sorted by numeric values in ascending order and the numeric values must approximately match the weights in the font files. */ @@ -2759,10 +2761,31 @@ font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size) continue; } for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++) - if (FIXNUMP (AREF (spec, prop)) - && ((XFIXNUM (AREF (spec, prop)) >> 8) - != (XFIXNUM (AREF (entity, prop)) >> 8))) - prop = FONT_SPEC_MAX; + { + if (FIXNUMP (AREF (spec, prop))) + { + int required = XFIXNUM (AREF (spec, prop)) >> 8; + int candidate = XFIXNUM (AREF (entity, prop)) >> 8; + + if (candidate != required +#ifdef HAVE_NTGUI + /* A kludge for w32 font search, where listing a + family returns only 4 standard weights: regular, + italic, bold, bold-italic. For other values one + must specify the font, not just the family in the + :family attribute of the face. But specifying + :family in the face attributes looks for regular + weight, so if we require exact match, the + non-regular font will be rejected. So we relax + the accuracy of the match here, and let + font_sort_entities find the best match. */ + && (prop != FONT_WEIGHT_INDEX + || eabs (candidate - required) > 100) +#endif + ) + prop = FONT_SPEC_MAX; + } + } if (prop < FONT_SPEC_MAX && size && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0) @@ -3162,8 +3185,9 @@ font_clear_prop (Lisp_Object *attrs, enum font_property_index prop) attrs[LFACE_FONT_INDEX] = font; } -/* Select a font from ENTITIES (list of font-entity vectors) that - supports C and is the best match for ATTRS and PIXEL_SIZE. */ +/* Select a font from ENTITIES (list of one or more font-entity + vectors) that supports the character C (if non-negative) and is the + best match for ATTRS and PIXEL_SIZE. */ static Lisp_Object font_select_entity (struct frame *f, Lisp_Object entities, @@ -3173,6 +3197,7 @@ font_select_entity (struct frame *f, Lisp_Object entities, Lisp_Object prefer; int i; + /* If we have a single candidate, return it if it supports C. */ if (NILP (XCDR (entities)) && ASIZE (XCAR (entities)) == 1) { @@ -3182,7 +3207,10 @@ font_select_entity (struct frame *f, Lisp_Object entities, return Qnil; } - /* Sort fonts by properties specified in ATTRS. */ + /* If we have several candidates, find the best match by sorting + them by properties specified in ATTRS. Style attributes (weight, + slant, width, and size) are taken from the font spec in ATTRS (if + that is non-nil), or from ATTRS, or left as nil. */ prefer = scratch_font_prefer; for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++) @@ -3219,6 +3247,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int int i, j, k, l; USE_SAFE_ALLOCA; + /* Registry specification alternatives: from the most specific to + the least specific and finally an unspecified one. */ registry[0] = AREF (spec, FONT_REGISTRY_INDEX); if (NILP (registry[0])) { @@ -3255,6 +3285,9 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int pixel_size = 1; } ASET (work, FONT_SIZE_INDEX, Qnil); + + /* Foundry specification alternatives: from the most specific to the + least specific and finally an unspecified one. */ foundry[0] = AREF (work, FONT_FOUNDRY_INDEX); if (! NILP (foundry[0])) foundry[1] = zero_vector; @@ -3268,6 +3301,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int else foundry[0] = Qnil, foundry[1] = zero_vector; + /* Additional style specification alternatives: from the most + specific to the least specific and finally an unspecified one. */ adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX); if (! NILP (adstyle[0])) adstyle[1] = zero_vector; @@ -3288,6 +3323,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int adstyle[0] = Qnil, adstyle[1] = zero_vector; + /* Family specification alternatives: from the most specific to + the least specific and finally an unspecified one. */ val = AREF (work, FONT_FAMILY_INDEX); if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX])) { @@ -3327,6 +3364,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int } } + /* Now look up suitable fonts, from the most specific spec to the + least specific spec. Accept the first one that matches. */ for (i = 0; SYMBOLP (family[i]); i++) { ASET (work, FONT_FAMILY_INDEX, family[i]); @@ -3339,9 +3378,12 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int for (l = 0; SYMBOLP (adstyle[l]); l++) { ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]); + /* Produce the list of candidates for the spec in WORK. */ entities = font_list_entities (f, work); if (! NILP (entities)) { + /* If there are several candidates, select the + best match for PIXEL_SIZE and attributes in ATTRS. */ val = font_select_entity (f, entities, attrs, pixel_size, c); if (! NILP (val)) @@ -5715,6 +5757,9 @@ match. */); #ifdef HAVE_NTGUI syms_of_w32font (); #endif /* HAVE_NTGUI */ +#ifdef USE_BE_CAIRO + syms_of_ftcrfont (); +#endif #endif /* HAVE_WINDOW_SYSTEM */ } diff --git a/src/font.h b/src/font.h index 1da72cca079..2da5ec45047 100644 --- a/src/font.h +++ b/src/font.h @@ -69,9 +69,10 @@ INLINE_HEADER_BEGIN enum font_property_index { - /* FONT-TYPE is a symbol indicating a font backend; currently `x' - and `xft' are available on X, `uniscribe' and `gdi' on - Windows, and `ns' under Cocoa / GNUstep. */ + /* FONT-TYPE is a symbol indicating a font backend; currently `x', + `xft', `xfthb', `ftrc', and `ftcrhb' are available on X; + `harfbuzz', `uniscribe', and `gdi' on Windows, and `ns' under + Cocoa / GNUstep. */ FONT_TYPE_INDEX, /* FONT-FOUNDRY is a foundry name (symbol). */ @@ -964,7 +965,7 @@ extern struct font_driver const nsfont_driver; extern void syms_of_nsfont (void); extern void syms_of_macfont (void); #endif /* HAVE_NS */ -#ifdef USE_CAIRO +#if defined (USE_CAIRO) || defined (USE_BE_CAIRO) extern struct font_driver const ftcrfont_driver; #ifdef HAVE_HARFBUZZ extern struct font_driver ftcrhbfont_driver; @@ -998,7 +999,7 @@ extern void font_deferred_log (const char *, Lisp_Object, Lisp_Object); INLINE bool font_data_structures_may_be_ill_formed (void) { -#ifdef USE_CAIRO +#if defined USE_CAIRO || defined USE_BE_CAIRO /* Although this works around Bug#20890, it is probably not the right thing to do. */ return gc_in_progress; diff --git a/src/frame.c b/src/frame.c index 585be79bf23..98f1b80e423 100644 --- a/src/frame.c +++ b/src/frame.c @@ -227,6 +227,7 @@ Value is: `ns' for an Emacs frame on a GNUstep or Macintosh Cocoa display, `pc' for a direct-write MS-DOS frame, `pgtk' for an Emacs frame running on pure GTK. + `haiku' for an Emacs frame running in Haiku. See also `frame-live-p'. */) (Lisp_Object object) { @@ -247,6 +248,8 @@ See also `frame-live-p'. */) return Qns; case output_pgtk: return Qpgtk; + case output_haiku: + return Qhaiku; default: emacs_abort (); } @@ -6036,6 +6039,7 @@ syms_of_frame (void) DEFSYM (Qpc, "pc"); DEFSYM (Qns, "ns"); DEFSYM (Qpgtk, "pgtk"); + DEFSYM (Qhaiku, "haiku"); DEFSYM (Qvisible, "visible"); DEFSYM (Qbuffer_predicate, "buffer-predicate"); DEFSYM (Qbuffer_list, "buffer-list"); diff --git a/src/frame.h b/src/frame.h index fa6cc4a5617..4060ee65c42 100644 --- a/src/frame.h +++ b/src/frame.h @@ -586,6 +586,7 @@ struct frame struct w32_output *w32; /* From w32term.h. */ struct ns_output *ns; /* From nsterm.h. */ struct pgtk_output *pgtk; /* From pgtkterm.h. */ + struct haiku_output *haiku; /* From haikuterm.h. */ } output_data; @@ -858,6 +859,11 @@ default_pixels_per_inch_y (void) #else #define FRAME_PGTK_P(f) ((f)->output_method == output_pgtk) #endif +#ifndef HAVE_HAIKU +#define FRAME_HAIKU_P(f) false +#else +#define FRAME_HAIKU_P(f) ((f)->output_method == output_haiku) +#endif /* FRAME_WINDOW_P tests whether the frame is a graphical window system frame. */ @@ -873,6 +879,9 @@ default_pixels_per_inch_y (void) #ifdef HAVE_PGTK #define FRAME_WINDOW_P(f) FRAME_PGTK_P(f) #endif +#ifdef HAVE_HAIKU +#define FRAME_WINDOW_P(f) FRAME_HAIKU_P (f) +#endif #ifndef FRAME_WINDOW_P #define FRAME_WINDOW_P(f) ((void) (f), false) #endif diff --git a/src/ftcrfont.c b/src/ftcrfont.c index 6a0411ff6d4..49b179b0efc 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -22,8 +22,12 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -#ifndef HAVE_PGTK +#ifdef HAVE_X_WINDOWS #include "xterm.h" +#elif HAVE_HAIKU +#include "haikuterm.h" +#include "haiku_support.h" +#include "termchar.h" #else #include "pgtkterm.h" #endif @@ -34,6 +38,12 @@ along with GNU Emacs. If not, see . */ #include "ftfont.h" #include "pdumper.h" +#ifdef USE_BE_CAIRO +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) +#endif + #define METRICS_NCOLS_PER_ROW (128) enum metrics_status @@ -517,19 +527,52 @@ ftcrfont_draw (struct glyph_string *s, block_input (); -#ifndef HAVE_PGTK +#ifndef USE_BE_CAIRO +#ifdef HAVE_X_WINDOWS cr = x_begin_cr_clip (f, s->gc); #else cr = pgtk_begin_cr_clip (f); #endif +#else + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + cr = haiku_begin_cr_clip (f, s); + if (!cr) + { + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + unblock_input (); + return 0; + } + BView_cr_dump_clipping (FRAME_HAIKU_VIEW (f), cr); + + if (s->left_overhang && s->clip_head && !s->for_overlaps) + { + cairo_rectangle (cr, s->clip_head->x, 0, + FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + cairo_clip (cr); + } +#endif if (with_background) { -#ifndef HAVE_PGTK +#ifndef USE_BE_CAIRO +#ifdef HAVE_X_WINDOWS x_set_cr_source_with_gc_background (f, s->gc); #else pgtk_set_cr_source_with_color (f, s->xgcv.background); #endif +#else + struct face *face = s->face; + + uint32_t col = s->hl == DRAW_CURSOR ? + FRAME_CURSOR_COLOR (s->f).pixel : face->background; + + cairo_set_source_rgb (cr, RED_FROM_ULONG (col) / 255.0, + GREEN_FROM_ULONG (col) / 255.0, + BLUE_FROM_ULONG (col) / 255.0); +#endif + s->background_filled_p = 1; cairo_rectangle (cr, x, y - FONT_BASE (face->font), s->width, FONT_HEIGHT (face->font)); cairo_fill (cr); @@ -545,21 +588,33 @@ ftcrfont_draw (struct glyph_string *s, glyphs[i].index, NULL)); } - -#ifndef HAVE_PGTK +#ifndef USE_BE_CAIRO +#ifdef HAVE_X_WINDOWS x_set_cr_source_with_gc_foreground (f, s->gc); #else pgtk_set_cr_source_with_color (f, s->xgcv.foreground); +#endif +#else + uint32_t col = s->hl == DRAW_CURSOR ? + FRAME_OUTPUT_DATA (s->f)->cursor_fg : face->foreground; + + cairo_set_source_rgb (cr, RED_FROM_ULONG (col) / 255.0, + GREEN_FROM_ULONG (col) / 255.0, + BLUE_FROM_ULONG (col) / 255.0); #endif cairo_set_scaled_font (cr, ftcrfont_info->cr_scaled_font); cairo_show_glyphs (cr, glyphs, len); - -#ifndef HAVE_PGTK +#ifndef USE_BE_CAIRO +#ifdef HAVE_X_WINDOWS x_end_cr_clip (f); #else pgtk_end_cr_clip (f); #endif - +#else + haiku_end_cr_clip (cr); + EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); +#endif unblock_input (); return len; diff --git a/src/ftfont.c b/src/ftfont.c index 03e44ec30ee..cf592759ab6 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -3108,6 +3108,10 @@ syms_of_ftfont (void) Fput (Qfreetype, Qfont_driver_superseded_by, Qfreetypehb); #endif /* HAVE_HARFBUZZ */ +#ifdef HAVE_HAIKU + DEFSYM (Qmono, "mono"); +#endif + /* Fontconfig's generic families and their aliases. */ DEFSYM (Qmonospace, "monospace"); DEFSYM (Qsans_serif, "sans-serif"); diff --git a/src/ftfont.h b/src/ftfont.h index 94050ddc7bb..cfab8d3154f 100644 --- a/src/ftfont.h +++ b/src/ftfont.h @@ -30,6 +30,10 @@ along with GNU Emacs. If not, see . */ # include FT_BDF_H #endif +#ifdef USE_BE_CAIRO +#include +#endif + #ifdef HAVE_HARFBUZZ #include #include @@ -63,7 +67,7 @@ struct font_info hb_font_t *hb_font; #endif /* HAVE_HARFBUZZ */ -#ifdef USE_CAIRO +#if defined (USE_CAIRO) || defined (USE_BE_CAIRO) cairo_scaled_font_t *cr_scaled_font; /* Scale factor from the bitmap strike metrics in 1/64 pixels, used as the hb_position_t value in HarfBuzz, to those in (scaled) diff --git a/src/gtkutil.c b/src/gtkutil.c index d4823f813bc..1cb90b85cf5 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -54,6 +54,10 @@ typedef struct pgtk_output xp_output; #include +#ifdef HAVE_XINPUT2 +#include +#endif + #ifdef HAVE_XFT #include #endif @@ -948,6 +952,27 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level, } #endif +#if defined HAVE_GTK3 && defined HAVE_XINPUT2 +bool +xg_is_menu_window (Display *dpy, Window wdesc) +{ + GtkWidget *gwdesc = xg_win_to_widget (dpy, wdesc); + + if (GTK_IS_WINDOW (gwdesc)) + { + GtkWidget *fw = gtk_bin_get_child (GTK_BIN (gwdesc)); + if (GTK_IS_MENU (fw)) + { + GtkWidget *parent + = gtk_menu_shell_get_parent_shell (GTK_MENU_SHELL (fw)); + return GTK_IS_MENU_BAR (parent); + } + } + + return false; +} +#endif + /* Make a geometry string and pass that to GTK. It seems this is the only way to get geometry position right if the user explicitly asked for a position when starting Emacs. @@ -3983,6 +4008,18 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) if (! x->menubar_widget) return 0; +#ifdef HAVE_XINPUT2 + XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; + if (event->type == GenericEvent) /* XI_ButtonPress or XI_ButtonRelease */ + { + if (! (xev->event_x >= 0 + && xev->event_x < FRAME_PIXEL_WIDTH (f) + && xev->event_y >= 0 + && xev->event_y < FRAME_MENUBAR_HEIGHT (f))) + return 0; + } + else +#endif if (! (event->xbutton.x >= 0 && event->xbutton.x < FRAME_PIXEL_WIDTH (f) && event->xbutton.y >= 0 @@ -3991,7 +4028,12 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) return 0; gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); - gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent) + gw = gdk_x11_window_lookup_for_display (gdpy, xev->event); + else +#endif + gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); if (! gw) return 0; gevent.any.window = gw; gevent.any.type = GDK_NOTHING; @@ -4682,6 +4724,18 @@ xg_event_is_for_scrollbar (struct frame *f, const EVENT *event) { bool retval = 0; +#ifdef HAVE_XINPUT2 + XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; + if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 + && event->type == GenericEvent + && (event->xgeneric.extension + == FRAME_DISPLAY_INFO (f)->xi2_opcode) + && ((event->xgeneric.evtype == XI_ButtonPress + && xev->detail < 4) + || (event->xgeneric.evtype == XI_Motion))) + || (event->type == ButtonPress + && event->xbutton.button < 4))) +#else if (f #ifndef HAVE_PGTK && event->type == ButtonPress && event->xbutton.button < 4 @@ -4689,6 +4743,7 @@ xg_event_is_for_scrollbar (struct frame *f, const EVENT *event) && event->type == GDK_BUTTON_PRESS && event->button.button < 4 #endif ) +#endif /* HAVE_XINPUT2 */ { /* Check if press occurred outside the edit widget. */ #ifndef HAVE_PGTK @@ -4710,7 +4765,25 @@ xg_event_is_for_scrollbar (struct frame *f, const EVENT *event) gwin = gdk_display_get_window_at_pointer (gdpy, NULL, NULL); #endif retval = gwin != gtk_widget_get_window (f->output_data.xp->edit_widget); +#ifdef HAVE_XINPUT2 + GtkWidget *grab = gtk_grab_get_current (); + if (event->type == GenericEvent + && event->xgeneric.evtype == XI_Motion) + retval = retval || (grab && GTK_IS_SCROLLBAR (grab)); +#endif } +#ifdef HAVE_XINPUT2 + else if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 + && event->type == GenericEvent + && (event->xgeneric.extension + == FRAME_DISPLAY_INFO (f)->xi2_opcode) + && ((event->xgeneric.evtype == XI_ButtonRelease + && xev->detail < 4) + || (event->xgeneric.evtype == XI_Motion))) + || ((event->type == ButtonRelease + && event->xbutton.button < 4) + || event->type == MotionNotify))) +#else else if (f #ifndef HAVE_PGTK && ((event->type == ButtonRelease && event->xbutton.button < 4) @@ -4720,6 +4793,8 @@ xg_event_is_for_scrollbar (struct frame *f, const EVENT *event) || event->type == GDK_MOTION_NOTIFY) #endif ) + || event->type == MotionNotify)) +#endif /* HAVE_XINPUT2 */ { /* If we are releasing or moving the scroll bar, it has the grab. */ GtkWidget *w = gtk_grab_get_current (); diff --git a/src/gtkutil.h b/src/gtkutil.h index 4afdfe7405a..9c6160dd772 100644 --- a/src/gtkutil.h +++ b/src/gtkutil.h @@ -213,6 +213,10 @@ extern Lisp_Object xg_get_page_setup (void); extern void xg_print_frames_dialog (Lisp_Object); #endif +#if defined HAVE_GTK3 && defined HAVE_XINPUT2 +extern bool xg_is_menu_window (Display *dpy, Window); +#endif + /* Mark all callback data that are Lisp_object:s during GC. */ extern void xg_mark_data (void); diff --git a/src/haiku.c b/src/haiku.c new file mode 100644 index 00000000000..485d86983c2 --- /dev/null +++ b/src/haiku.c @@ -0,0 +1,286 @@ +/* Haiku subroutines that are general to the Haiku operating system. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "process.h" +#include "coding.h" + +#include + +#include +#include + +Lisp_Object +list_system_processes (void) +{ + team_info info; + int32 cookie = 0; + Lisp_Object lval = Qnil; + + while (get_next_team_info (&cookie, &info) == B_OK) + lval = Fcons (make_fixnum (info.team), lval); + + return lval; +} + +Lisp_Object +system_process_attributes (Lisp_Object pid) +{ + CHECK_FIXNUM (pid); + + team_info info; + Lisp_Object lval = Qnil; + thread_info inf; + area_info area; + team_id id = (team_id) XFIXNUM (pid); + struct passwd *g; + size_t mem = 0; + + if (get_team_info (id, &info) != B_OK) + return Qnil; + + bigtime_t everything = 0, vsample = 0; + bigtime_t cpu_eaten = 0, esample = 0; + + lval = Fcons (Fcons (Qeuid, make_fixnum (info.uid)), lval); + lval = Fcons (Fcons (Qegid, make_fixnum (info.gid)), lval); + lval = Fcons (Fcons (Qthcount, make_fixnum (info.thread_count)), lval); + lval = Fcons (Fcons (Qcomm, build_string_from_utf8 (info.args)), lval); + + g = getpwuid (info.uid); + + if (g && g->pw_name) + lval = Fcons (Fcons (Quser, build_string (g->pw_name)), lval); + + /* FIXME: Calculating this makes Emacs show up as using 100% CPU! */ + + for (int32 team_cookie = 0; + get_next_team_info (&team_cookie, &info) == B_OK;) + for (int32 thread_cookie = 0; + get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;) + { + if (inf.team == id && strncmp (inf.name, "idle thread ", 12)) + cpu_eaten += inf.user_time + inf.kernel_time; + everything += inf.user_time + inf.kernel_time; + } + + sleep (0.05); + + for (int32 team_cookie = 0; + get_next_team_info (&team_cookie, &info) == B_OK;) + for (int32 thread_cookie = 0; + get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;) + { + if (inf.team == id && strncmp (inf.name, "idle thread ", 12)) + esample += inf.user_time + inf.kernel_time; + vsample += inf.user_time + inf.kernel_time; + } + + cpu_eaten = esample - cpu_eaten; + everything = vsample - everything; + + if (everything) + lval = Fcons (Fcons (Qpcpu, make_float (((double) (cpu_eaten) / + (double) (everything)) * 100)), + lval); + else + lval = Fcons (Fcons (Qpcpu, make_float (0.0)), lval); + + for (ssize_t area_cookie = 0; + get_next_area_info (id, &area_cookie, &area) == B_OK;) + mem += area.ram_size; + + system_info sinfo; + get_system_info (&sinfo); + int64 max = (int64) sinfo.max_pages * B_PAGE_SIZE; + + lval = Fcons (Fcons (Qpmem, make_float (((double) mem / + (double) max) * 100)), + lval); + lval = Fcons (Fcons (Qrss, make_fixnum (mem / 1024)), lval); + + return lval; +} + + +/* Borrowed from w32 implementation. */ + +struct load_sample +{ + time_t sample_time; + bigtime_t idle; + bigtime_t kernel; + bigtime_t user; +}; + +/* We maintain 1-sec samples for the last 16 minutes in a circular buffer. */ +static struct load_sample samples[16*60]; +static int first_idx = -1, last_idx = -1; +static int max_idx = ARRAYELTS (samples); +static unsigned num_of_processors = 0; + +static int +buf_next (int from) +{ + int next_idx = from + 1; + + if (next_idx >= max_idx) + next_idx = 0; + + return next_idx; +} + +static int +buf_prev (int from) +{ + int prev_idx = from - 1; + + if (prev_idx < 0) + prev_idx = max_idx - 1; + + return prev_idx; +} + +static double +getavg (int which) +{ + double retval = -1.0; + double tdiff; + int idx; + double span = (which == 0 ? 1.0 : (which == 1 ? 5.0 : 15.0)) * 60; + time_t now = samples[last_idx].sample_time; + + if (first_idx != last_idx) + { + for (idx = buf_prev (last_idx); ; idx = buf_prev (idx)) + { + tdiff = difftime (now, samples[idx].sample_time); + if (tdiff >= span - 2 * DBL_EPSILON * now) + { + long double sys = + (samples[last_idx].kernel + samples[last_idx].user) - + (samples[idx].kernel + samples[idx].user); + long double idl = samples[last_idx].idle - samples[idx].idle; + + retval = (idl / (sys + idl)) * num_of_processors; + break; + } + if (idx == first_idx) + break; + } + } + + return retval; +} + +static void +sample_sys_load (bigtime_t *idle, bigtime_t *system, bigtime_t *user) +{ + bigtime_t i = 0, s = 0, u = 0; + team_info info; + thread_info inf; + + for (int32 team_cookie = 0; + get_next_team_info (&team_cookie, &info) == B_OK;) + for (int32 thread_cookie = 0; + get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;) + { + if (!strncmp (inf.name, "idle thread ", 12)) + i += inf.user_time + inf.kernel_time; + else + s += inf.kernel_time, u += inf.user_time; + } + + *idle = i; + *system = s; + *user = u; +} + +int +getloadavg (double loadavg[], int nelem) +{ + int elem; + bigtime_t idle, kernel, user; + time_t now = time (NULL); + + if (num_of_processors <= 0) + { + system_info i; + if (get_system_info (&i) == B_OK) + num_of_processors = i.cpu_count; + } + + /* If system time jumped back for some reason, delete all samples + whose time is later than the current wall-clock time. This + prevents load average figures from becoming frozen for prolonged + periods of time, when system time is reset backwards. */ + if (last_idx >= 0) + { + while (difftime (now, samples[last_idx].sample_time) < -1.0) + { + if (last_idx == first_idx) + { + first_idx = last_idx = -1; + break; + } + last_idx = buf_prev (last_idx); + } + } + + /* Store another sample. We ignore samples that are less than 1 sec + apart. */ + if (last_idx < 0 + || (difftime (now, samples[last_idx].sample_time) + >= 1.0 - 2 * DBL_EPSILON * now)) + { + sample_sys_load (&idle, &kernel, &user); + last_idx = buf_next (last_idx); + samples[last_idx].sample_time = now; + samples[last_idx].idle = idle; + samples[last_idx].kernel = kernel; + samples[last_idx].user = user; + /* If the buffer has more that 15 min worth of samples, discard + the old ones. */ + if (first_idx == -1) + first_idx = last_idx; + while (first_idx != last_idx + && (difftime (now, samples[first_idx].sample_time) + >= 15.0 * 60 + 2 * DBL_EPSILON * now)) + first_idx = buf_next (first_idx); + } + + for (elem = 0; elem < nelem; elem++) + { + double avg = getavg (elem); + + if (avg < 0) + break; + loadavg[elem] = avg; + } + + /* Always return at least one element, otherwise load-average + returns nil, and Lisp programs might decide we cannot measure + system load. For example, jit-lock-stealth-load's defcustom + might decide that feature is "unsupported". */ + if (elem == 0) + loadavg[elem++] = 0.09; /* < display-time-load-average-threshold */ + + return elem; +} diff --git a/src/haiku_draw_support.cc b/src/haiku_draw_support.cc new file mode 100644 index 00000000000..5b1eccfbe6e --- /dev/null +++ b/src/haiku_draw_support.cc @@ -0,0 +1,488 @@ +/* Haiku window system support. Hey, Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include +#include +#include + +#include + +#include "haiku_support.h" + +#define RGB_TO_UINT32(r, g, b) ((255 << 24) | ((r) << 16) | ((g) << 8) | (b)) +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) + +#define RGB_COLOR_UINT32(r) RGB_TO_UINT32 ((r).red, (r).green, (r).blue) + +static void +rgb32_to_rgb_color (uint32_t rgb, rgb_color *color) +{ + color->red = RED_FROM_ULONG (rgb); + color->green = GREEN_FROM_ULONG (rgb); + color->blue = BLUE_FROM_ULONG (rgb); + color->alpha = 255; +} + +static BView * +get_view (void *vw) +{ + BView *view = (BView *) find_appropriate_view_for_draw (vw); + return view; +} + +void +BView_StartClip (void *view) +{ + BView *vw = get_view (view); + vw->PushState (); +} + +void +BView_EndClip (void *view) +{ + BView *vw = get_view (view); + vw->PopState (); +} + +void +BView_SetHighColor (void *view, uint32_t color) +{ + BView *vw = get_view (view); + rgb_color col; + rgb32_to_rgb_color (color, &col); + + vw->SetHighColor (col); +} + +void +BView_SetLowColor (void *view, uint32_t color) +{ + BView *vw = get_view (view); + rgb_color col; + rgb32_to_rgb_color (color, &col); + + vw->SetLowColor (col); +} + +void +BView_SetPenSize (void *view, int u) +{ + BView *vw = get_view (view); + vw->SetPenSize (u); +} + +void +BView_FillRectangle (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->FillRect (rect); +} + +void +BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x1, y1); + + vw->FillRect (rect); +} + +void +BView_StrokeRectangle (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->StrokeRect (rect); +} + +void +BView_SetViewColor (void *view, uint32_t color) +{ + BView *vw = get_view (view); + rgb_color col; + rgb32_to_rgb_color (color, &col); + +#ifndef USE_BE_CAIRO + vw->SetViewColor (col); +#else + vw->SetViewColor (B_TRANSPARENT_32_BIT); +#endif +} + +void +BView_ClipToRect (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->ClipToRect (rect); +} + +void +BView_ClipToInverseRect (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->ClipToInverseRect (rect); +} + +void +BView_StrokeLine (void *view, int sx, int sy, int tx, int ty) +{ + BView *vw = get_view (view); + BPoint from = BPoint (sx, sy); + BPoint to = BPoint (tx, ty); + + vw->StrokeLine (from, to); +} + +void +BView_SetFont (void *view, void *font) +{ + BView *vw = get_view (view); + + vw->SetFont ((BFont *) font); +} + +void +BView_MovePenTo (void *view, int x, int y) +{ + BView *vw = get_view (view); + BPoint pt = BPoint (x, y); + + vw->MovePenTo (pt); +} + +void +BView_DrawString (void *view, const char *chr, ptrdiff_t len) +{ + BView *vw = get_view (view); + + vw->DrawString (chr, len); +} + +void +BView_DrawChar (void *view, char chr) +{ + BView *vw = get_view (view); + + vw->DrawChar (chr); +} + +void +BView_CopyBits (void *view, int x, int y, int width, int height, + int tox, int toy, int towidth, int toheight) +{ + BView *vw = get_view (view); + + vw->CopyBits (BRect (x, y, x + width - 1, y + height - 1), + BRect (tox, toy, tox + towidth - 1, toy + toheight - 1)); + vw->Sync (); +} + +/* Convert RGB32 color color from RGB color space to its + HSL components pointed to by H, S and L. */ +void +rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l) +{ + rgb_color col; + rgb32_to_rgb_color (rgb, &col); + + double red = col.red / 255.0; + double green = col.green / 255.0; + double blue = col.blue / 255.0; + + double max = std::fmax (std::fmax (red, blue), green); + double min = std::fmin (std::fmin (red, blue), green); + double delta = max - min; + *l = (max + min) / 2.0; + + if (!delta) + { + *h = 0; + *s = 0; + return; + } + + *s = (*l < 0.5) ? delta / (max + min) : + delta / (20 - max - min); + double rc = (max - red) / delta; + double gc = (max - green) / delta; + double bc = (max - blue) / delta; + + if (red == max) + *h = bc - gc; + else if (green == max) + *h = 2.0 + rc + -bc; + else + *h = 4.0 + gc + -rc; + *h = std::fmod (*h / 6, 1.0); +} + +static double +hue_to_rgb (double v1, double v2, double h) +{ + if (h < 1 / 6) + return v1 + (v2 - v1) * h * 6.0; + else if (h < 0.5) + return v2; + else if (h < 2.0 / 3) + return v1 + (v2 - v1) * (2.0 / 3 - h) * 6.0; + return v1; +} + +void +hsl_color_rgb (double h, double s, double l, uint32_t *rgb) +{ + if (!s) + *rgb = RGB_TO_UINT32 (std::lrint (l * 255), + std::lrint (l * 255), + std::lrint (l * 255)); + else + { + double m2 = l <= 0.5 ? l * (1 + s) : l + s - l * s; + double m1 = 2.0 * l - m2; + + *rgb = RGB_TO_UINT32 + (std::lrint (hue_to_rgb (m1, m2, + std::fmod (h + 1 / 3.0, 1)) * 255), + std::lrint (hue_to_rgb (m1, m2, h) * 255), + std::lrint (hue_to_rgb (m1, m2, + std::fmod (h - 1 / 3.0, 1)) * 255)); + } +} + +void +BView_DrawBitmap (void *view, void *bitmap, int x, int y, + int width, int height, int vx, int vy, int vwidth, + int vheight) +{ + BView *vw = get_view (view); + BBitmap *bm = (BBitmap *) bitmap; + + vw->PushState (); + vw->SetDrawingMode (B_OP_OVER); + vw->DrawBitmap (bm, BRect (x, y, x + width - 1, y + height - 1), + BRect (vx, vy, vx + vwidth - 1, vy + vheight - 1)); + vw->PopState (); +} + +void +BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x, + int y, int width, int height) +{ + BView *vw = get_view (view); + BBitmap *bm = (BBitmap *) bitmap; + BBitmap bc (bm->Bounds (), B_RGBA32); + BRect rect (x, y, x + width - 1, y + height - 1); + + if (bc.InitCheck () != B_OK || bc.ImportBits (bm) != B_OK) + return; + + uint32_t *bits = (uint32_t *) bc.Bits (); + size_t stride = bc.BytesPerRow (); + + if (bm->ColorSpace () == B_GRAY1) + { + rgb_color low_color = vw->LowColor (); + for (int y = 0; y <= bc.Bounds ().Height (); ++y) + { + for (int x = 0; x <= bc.Bounds ().Width (); ++x) + { + if (bits[y * (stride / 4) + x] == 0xFF000000) + bits[y * (stride / 4) + x] = RGB_COLOR_UINT32 (low_color); + else + bits[y * (stride / 4) + x] = 0; + } + } + } + + vw->PushState (); + vw->SetDrawingMode (bm->ColorSpace () == B_GRAY1 ? B_OP_OVER : B_OP_ERASE); + vw->DrawBitmap (&bc, rect); + vw->PopState (); +} + +void +BView_DrawMask (void *src, void *view, + int x, int y, int width, int height, + int vx, int vy, int vwidth, int vheight, + uint32_t color) +{ + BBitmap *source = (BBitmap *) src; + BBitmap bm (source->Bounds (), B_RGBA32); + if (bm.InitCheck () != B_OK) + return; + for (int y = 0; y <= bm.Bounds ().Height (); ++y) + { + for (int x = 0; x <= bm.Bounds ().Width (); ++x) + { + int bit = haiku_get_pixel ((void *) source, x, y); + + if (!bit) + haiku_put_pixel ((void *) &bm, x, y, ((uint32_t) 255 << 24) | color); + else + haiku_put_pixel ((void *) &bm, x, y, 0); + } + } + BView *vw = get_view (view); + vw->SetDrawingMode (B_OP_OVER); + vw->DrawBitmap (&bm, BRect (x, y, x + width - 1, y + height - 1), + BRect (vx, vy, vx + vwidth - 1, vy + vheight - 1)); +} + +static BBitmap * +rotate_bitmap_270 (BBitmap *bmp) +{ + BRect r = bmp->Bounds (); + BBitmap *bm = new BBitmap (BRect (r.top, r.left, r.bottom, r.right), + bmp->ColorSpace (), true); + if (bm->InitCheck () != B_OK) + gui_abort ("Failed to init bitmap for rotate"); + int w = bmp->Bounds ().Width () + 1; + int h = bmp->Bounds ().Height () + 1; + + for (int y = 0; y < h; ++y) + for (int x = 0; x < w; ++x) + haiku_put_pixel ((void *) bm, y, w - x - 1, + haiku_get_pixel ((void *) bmp, x, y)); + + return bm; +} + +static BBitmap * +rotate_bitmap_90 (BBitmap *bmp) +{ + BRect r = bmp->Bounds (); + BBitmap *bm = new BBitmap (BRect (r.top, r.left, r.bottom, r.right), + bmp->ColorSpace (), true); + if (bm->InitCheck () != B_OK) + gui_abort ("Failed to init bitmap for rotate"); + int w = bmp->Bounds ().Width () + 1; + int h = bmp->Bounds ().Height () + 1; + + for (int y = 0; y < h; ++y) + for (int x = 0; x < w; ++x) + haiku_put_pixel ((void *) bm, h - y - 1, x, + haiku_get_pixel ((void *) bmp, x, y)); + + return bm; +} + +void * +BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color, + double rot, int desw, int desh) +{ + BBitmap *bm = (BBitmap *) bitmap; + BBitmap *mk = (BBitmap *) mask; + int copied_p = 0; + + if (rot == 90) + { + copied_p = 1; + bm = rotate_bitmap_90 (bm); + if (mk) + mk = rotate_bitmap_90 (mk); + } + + if (rot == 270) + { + copied_p = 1; + bm = rotate_bitmap_270 (bm); + if (mk) + mk = rotate_bitmap_270 (mk); + } + + BRect r = bm->Bounds (); + if (r.Width () != desw || r.Height () != desh) + { + BRect n = BRect (0, 0, desw - 1, desh - 1); + BView vw (n, NULL, B_FOLLOW_NONE, 0); + BBitmap *dst = new BBitmap (n, bm->ColorSpace (), true); + if (dst->InitCheck () != B_OK) + if (bm->InitCheck () != B_OK) + gui_abort ("Failed to init bitmap for scale"); + dst->AddChild (&vw); + + if (!vw.LockLooper ()) + gui_abort ("Failed to lock offscreen view for scale"); + + if (rot != 90 && rot != 270) + { + BAffineTransform tr; + tr.RotateBy (BPoint (desw / 2, desh / 2), rot * M_PI / 180.0); + vw.SetTransform (tr); + } + + vw.MovePenTo (0, 0); + vw.DrawBitmap (bm, n); + if (mk) + BView_DrawMask ((void *) mk, (void *) &vw, + 0, 0, mk->Bounds ().Width (), + mk->Bounds ().Height (), + 0, 0, desw, desh, m_color); + vw.Sync (); + vw.RemoveSelf (); + + if (copied_p) + delete bm; + if (copied_p && mk) + delete mk; + return dst; + } + + return bm; +} + +void +BView_FillTriangle (void *view, int x1, int y1, + int x2, int y2, int x3, int y3) +{ + BView *vw = get_view (view); + vw->FillTriangle (BPoint (x1, y1), BPoint (x2, y2), + BPoint (x3, y3)); +} + +void +BView_SetHighColorForVisibleBell (void *view, uint32_t color) +{ + BView *vw = (BView *) view; + rgb_color col; + rgb32_to_rgb_color (color, &col); + + vw->SetHighColor (col); +} + +void +BView_FillRectangleForVisibleBell (void *view, int x, int y, int width, int height) +{ + BView *vw = (BView *) view; + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->FillRect (rect); +} diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc new file mode 100644 index 00000000000..9ac0400969b --- /dev/null +++ b/src/haiku_font_support.cc @@ -0,0 +1,596 @@ +/* Haiku window system support. Hey, Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include + +#include +#include + +#include "haiku_support.h" + +/* Haiku doesn't expose font language data in BFont objects. Thus, we + select a few representative characters for each supported `:lang' + (currently Chinese, Korean and Japanese,) and test for those + instead. */ + +static uint32_t language_code_points[MAX_LANGUAGE][4] = + {{20154, 20754, 22996, 0}, /* Chinese. */ + {51312, 49440, 44544, 0}, /* Korean. */ + {26085, 26412, 12371, 0}, /* Japanese. */}; + +static void +estimate_font_ascii (BFont *font, int *max_width, + int *min_width, int *avg_width) +{ + char ch[2]; + bool tems[1]; + int total = 0; + int count = 0; + int min = 0; + int max = 0; + + std::memset (ch, 0, sizeof ch); + for (ch[0] = 32; ch[0] < 127; ++ch[0]) + { + tems[0] = false; + font->GetHasGlyphs (ch, 1, tems); + if (tems[0]) + { + int w = font->StringWidth (ch); + ++count; + total += w; + + if (!min || min > w) + min = w; + if (max < w) + max = w; + } + } + + *min_width = min; + *max_width = max; + *avg_width = total / count; +} + +void +BFont_close (void *font) +{ + if (font != (void *) be_fixed_font && + font != (void *) be_plain_font && + font != (void *) be_bold_font) + delete (BFont *) font; +} + +void +BFont_dat (void *font, int *px_size, int *min_width, int *max_width, + int *avg_width, int *height, int *space_width, int *ascent, + int *descent, int *underline_position, int *underline_thickness) +{ + BFont *ft = (BFont *) font; + struct font_height fheight; + bool have_space_p; + + char atem[1]; + bool otem[1]; + + ft->GetHeight (&fheight); + atem[0] = ' '; + otem[0] = false; + ft->GetHasGlyphs (atem, 1, otem); + have_space_p = otem[0]; + + estimate_font_ascii (ft, max_width, min_width, avg_width); + *ascent = std::lrint (fheight.ascent); + *descent = std::lrint (fheight.descent); + *height = *ascent + *descent; + + *space_width = have_space_p ? ft->StringWidth (" ") : 0; + + *px_size = std::lrint (ft->Size ()); + *underline_position = 0; + *underline_thickness = 0; +} + +/* Return non-null if FONT contains CHR, a Unicode code-point. */ +int +BFont_have_char_p (void *font, int32_t chr) +{ + BFont *ft = (BFont *) font; + return ft->IncludesBlock (chr, chr); +} + +/* Return non-null if font contains a block from BEG to END. */ +int +BFont_have_char_block (void *font, int32_t beg, int32_t end) +{ + BFont *ft = (BFont *) font; + return ft->IncludesBlock (beg, end); +} + +/* Compute bounds for MB_STR, a character in multibyte encoding, + used with font. The width (in pixels) is returned in ADVANCE, + the left bearing in LB, and the right bearing in RB. */ +void +BFont_char_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb) +{ + BFont *ft = (BFont *) font; + edge_info edge_info; + float size, escapement; + size = ft->Size (); + + ft->GetEdges (mb_str, 1, &edge_info); + ft->GetEscapements (mb_str, 1, &escapement); + *advance = std::lrint (escapement * size); + *lb = std::lrint (edge_info.left * size); + *rb = *advance + std::lrint (edge_info.right * size); +} + +/* The same, but for a variable amount of chars. */ +void +BFont_nchar_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb, int32_t n) +{ + BFont *ft = (BFont *) font; + edge_info edge_info[n]; + float size; + float escapement[n]; + + size = ft->Size (); + + ft->GetEdges (mb_str, n, edge_info); + ft->GetEscapements (mb_str, n, (float *) escapement); + + for (int32_t i = 0; i < n; ++i) + { + advance[i] = std::lrint (escapement[i] * size); + lb[i] = advance[i] - std::lrint (edge_info[i].left * size); + rb[i] = advance[i] + std::lrint (edge_info[i].right * size); + } +} + +static void +font_style_to_flags (char *st, struct haiku_font_pattern *pattern) +{ + char *style = strdup (st); + char *token; + pattern->weight = -1; + pattern->width = NO_WIDTH; + pattern->slant = NO_SLANT; + int tok = 0; + + while ((token = std::strtok (!tok ? style : NULL, " ")) && tok < 3) + { + if (token && !strcmp (token, "Thin")) + pattern->weight = HAIKU_THIN; + else if (token && !strcmp (token, "UltraLight")) + pattern->weight = HAIKU_ULTRALIGHT; + else if (token && !strcmp (token, "ExtraLight")) + pattern->weight = HAIKU_EXTRALIGHT; + else if (token && !strcmp (token, "Light")) + pattern->weight = HAIKU_LIGHT; + else if (token && !strcmp (token, "SemiLight")) + pattern->weight = HAIKU_SEMI_LIGHT; + else if (token && !strcmp (token, "Regular")) + { + if (pattern->slant == NO_SLANT) + pattern->slant = SLANT_REGULAR; + + if (pattern->width == NO_WIDTH) + pattern->width = NORMAL_WIDTH; + + if (pattern->weight == -1) + pattern->weight = HAIKU_REGULAR; + } + else if (token && !strcmp (token, "SemiBold")) + pattern->weight = HAIKU_SEMI_BOLD; + else if (token && !strcmp (token, "Bold")) + pattern->weight = HAIKU_BOLD; + else if (token && (!strcmp (token, "ExtraBold") || + /* This has actually been seen in the wild. */ + !strcmp (token, "Extrabold"))) + pattern->weight = HAIKU_EXTRA_BOLD; + else if (token && !strcmp (token, "UltraBold")) + pattern->weight = HAIKU_ULTRA_BOLD; + else if (token && !strcmp (token, "Book")) + pattern->weight = HAIKU_BOOK; + else if (token && !strcmp (token, "Heavy")) + pattern->weight = HAIKU_HEAVY; + else if (token && !strcmp (token, "UltraHeavy")) + pattern->weight = HAIKU_ULTRA_HEAVY; + else if (token && !strcmp (token, "Black")) + pattern->weight = HAIKU_BLACK; + else if (token && !strcmp (token, "Medium")) + pattern->weight = HAIKU_MEDIUM; + else if (token && !strcmp (token, "Oblique")) + pattern->slant = SLANT_OBLIQUE; + else if (token && !strcmp (token, "Italic")) + pattern->slant = SLANT_ITALIC; + else if (token && !strcmp (token, "UltraCondensed")) + pattern->width = ULTRA_CONDENSED; + else if (token && !strcmp (token, "ExtraCondensed")) + pattern->width = EXTRA_CONDENSED; + else if (token && !strcmp (token, "Condensed")) + pattern->width = CONDENSED; + else if (token && !strcmp (token, "SemiCondensed")) + pattern->width = SEMI_CONDENSED; + else if (token && !strcmp (token, "SemiExpanded")) + pattern->width = SEMI_EXPANDED; + else if (token && !strcmp (token, "Expanded")) + pattern->width = EXPANDED; + else if (token && !strcmp (token, "ExtraExpanded")) + pattern->width = EXTRA_EXPANDED; + else if (token && !strcmp (token, "UltraExpanded")) + pattern->width = ULTRA_EXPANDED; + else + { + tok = 1000; + break; + } + tok++; + } + + if (pattern->weight != -1) + pattern->specified |= FSPEC_WEIGHT; + if (pattern->slant != NO_SLANT) + pattern->specified |= FSPEC_SLANT; + if (pattern->width != NO_WIDTH) + pattern->specified |= FSPEC_WIDTH; + + if (tok > 3) + { + pattern->specified &= ~FSPEC_SLANT; + pattern->specified &= ~FSPEC_WEIGHT; + pattern->specified &= ~FSPEC_WIDTH; + pattern->specified |= FSPEC_STYLE; + std::strncpy ((char *) &pattern->style, st, + sizeof pattern->style - 1); + } + + free (style); +} + +static bool +font_check_wanted_chars (struct haiku_font_pattern *pattern, font_family family, + char *style) +{ + BFont ft; + + if (ft.SetFamilyAndStyle (family, style) != B_OK) + return false; + + for (int i = 0; i < pattern->want_chars_len; ++i) + if (!ft.IncludesBlock (pattern->wanted_chars[i], + pattern->wanted_chars[i])) + return false; + + return true; +} + +static bool +font_check_one_of (struct haiku_font_pattern *pattern, font_family family, + char *style) +{ + BFont ft; + + if (ft.SetFamilyAndStyle (family, style) != B_OK) + return false; + + for (int i = 0; i < pattern->need_one_of_len; ++i) + if (ft.IncludesBlock (pattern->need_one_of[i], + pattern->need_one_of[i])) + return true; + + return false; +} + +static bool +font_check_language (struct haiku_font_pattern *pattern, font_family family, + char *style) +{ + BFont ft; + + if (ft.SetFamilyAndStyle (family, style) != B_OK) + return false; + + if (pattern->language == MAX_LANGUAGE) + return false; + + for (uint32_t *ch = (uint32_t *) + &language_code_points[pattern->language]; *ch; ch++) + if (!ft.IncludesBlock (*ch, *ch)) + return false; + + return true; +} + +static bool +font_family_style_matches_p (font_family family, char *style, uint32_t flags, + struct haiku_font_pattern *pattern, + int ignore_flags_p = 0) +{ + struct haiku_font_pattern m; + m.specified = 0; + + if (style) + font_style_to_flags (style, &m); + + if ((pattern->specified & FSPEC_FAMILY) && + strcmp ((char *) &pattern->family, family)) + return false; + + if (!ignore_flags_p && (pattern->specified & FSPEC_SPACING) && + !(pattern->mono_spacing_p) != !(flags & B_IS_FIXED)) + return false; + + if (pattern->specified & FSPEC_STYLE) + return style && !strcmp (style, pattern->style); + + if ((pattern->specified & FSPEC_WEIGHT) + && (pattern->weight + != ((m.specified & FSPEC_WEIGHT) ? m.weight : HAIKU_REGULAR))) + return false; + + if ((pattern->specified & FSPEC_SLANT) + && (pattern->slant + != ((m.specified & FSPEC_SLANT) ? m.slant : SLANT_REGULAR))) + return false; + + if ((pattern->specified & FSPEC_WANTED) + && !font_check_wanted_chars (pattern, family, style)) + return false; + + if ((pattern->specified & FSPEC_WIDTH) + && (pattern->width != + ((m.specified & FSPEC_WIDTH) ? m.width : NORMAL_WIDTH))) + return false; + + if ((pattern->specified & FSPEC_NEED_ONE_OF) + && !font_check_one_of (pattern, family, style)) + return false; + + if ((pattern->specified & FSPEC_LANGUAGE) + && !font_check_language (pattern, family, style)) + return false; + + return true; +} + +static void +haiku_font_fill_pattern (struct haiku_font_pattern *pattern, + font_family family, char *style, + uint32_t flags) +{ + if (style) + font_style_to_flags (style, pattern); + + pattern->specified |= FSPEC_FAMILY; + std::strncpy (pattern->family, family, + sizeof pattern->family - 1); + pattern->specified |= FSPEC_SPACING; + pattern->mono_spacing_p = flags & B_IS_FIXED; +} + +/* Delete every element of the font pattern PT. */ +void +haiku_font_pattern_free (struct haiku_font_pattern *pt) +{ + struct haiku_font_pattern *tem = pt; + while (tem) + { + struct haiku_font_pattern *t = tem; + tem = t->next; + delete t; + } +} + +/* Find all fonts matching the font pattern PT. */ +struct haiku_font_pattern * +BFont_find (struct haiku_font_pattern *pt) +{ + struct haiku_font_pattern *r = NULL; + font_family name; + font_style sname; + uint32 flags; + int sty_count; + int fam_count = count_font_families (); + + for (int fi = 0; fi < fam_count; ++fi) + { + if (get_font_family (fi, &name, &flags) == B_OK) + { + sty_count = count_font_styles (name); + if (!sty_count && + font_family_style_matches_p (name, NULL, flags, pt)) + { + struct haiku_font_pattern *p = new struct haiku_font_pattern; + p->specified = 0; + p->oblique_seen_p = 1; + haiku_font_fill_pattern (p, name, NULL, flags); + p->next = r; + if (p->next) + p->next->last = p; + p->last = NULL; + p->next_family = r; + r = p; + } + else if (sty_count) + { + for (int si = 0; si < sty_count; ++si) + { + int oblique_seen_p = 0; + struct haiku_font_pattern *head = r; + struct haiku_font_pattern *p = NULL; + + if (get_font_style (name, si, &sname, &flags) == B_OK) + { + if (font_family_style_matches_p (name, (char *) &sname, flags, pt)) + { + p = new struct haiku_font_pattern; + p->specified = 0; + haiku_font_fill_pattern (p, name, (char *) &sname, flags); + if (p->specified & FSPEC_SLANT && + ((p->slant == SLANT_OBLIQUE) || (p->slant == SLANT_ITALIC))) + oblique_seen_p = 1; + + p->next = r; + if (p->next) + p->next->last = p; + r = p; + p->next_family = head; + } + } + + if (p) + p->last = NULL; + + for (; head; head = head->last) + { + head->oblique_seen_p = oblique_seen_p; + } + } + } + } + } + + /* There's a very good chance that this result will get cached if no + slant is specified. Thus, we look through each font that hasn't + seen an oblique style, and add one. */ + + if (!(pt->specified & FSPEC_SLANT)) + { + /* r->last is invalid from here onwards. */ + for (struct haiku_font_pattern *p = r; p;) + { + if (!p->oblique_seen_p) + { + struct haiku_font_pattern *n = new haiku_font_pattern; + *n = *p; + n->slant = SLANT_OBLIQUE; + p->next = n; + p = p->next_family; + } + else + p = p->next_family; + } + } + + return r; +} + +/* Find and open a font matching the pattern PAT, which must have its + family set. */ +int +BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) +{ + int sty_count; + font_family name; + font_style sname; + uint32 flags = 0; + if (!(pat->specified & FSPEC_FAMILY)) + return 1; + strncpy (name, pat->family, sizeof name - 1); + sty_count = count_font_styles (name); + + if (!sty_count && + font_family_style_matches_p (name, NULL, flags, pat, 1)) + { + BFont *ft = new BFont; + if (ft->SetFamilyAndStyle (name, NULL) != B_OK) + { + delete ft; + return 1; + } + ft->SetSize (size); + ft->SetEncoding (B_UNICODE_UTF8); + ft->SetSpacing (B_BITMAP_SPACING); + *font = (void *) ft; + return 0; + } + else if (sty_count) + { + for (int si = 0; si < sty_count; ++si) + { + if (get_font_style (name, si, &sname, &flags) == B_OK && + font_family_style_matches_p (name, (char *) &sname, flags, pat)) + { + BFont *ft = new BFont; + if (ft->SetFamilyAndStyle (name, sname) != B_OK) + { + delete ft; + return 1; + } + ft->SetSize (size); + ft->SetEncoding (B_UNICODE_UTF8); + ft->SetSpacing (B_BITMAP_SPACING); + *font = (void *) ft; + return 0; + } + } + } + + if (pat->specified & FSPEC_SLANT && pat->slant == SLANT_OBLIQUE) + { + struct haiku_font_pattern copy = *pat; + copy.slant = SLANT_REGULAR; + int code = BFont_open_pattern (©, font, size); + if (code) + return code; + BFont *ft = (BFont *) *font; + /* XXX Font measurements don't respect shear. Haiku bug? + This apparently worked in BeOS. + ft->SetShear (100.0); */ + ft->SetFace (B_ITALIC_FACE); + return 0; + } + + return 1; +} + +/* Query the family of the default fixed font. */ +void +BFont_populate_fixed_family (struct haiku_font_pattern *ptn) +{ + font_family f; + font_style s; + be_fixed_font->GetFamilyAndStyle (&f, &s); + + ptn->specified |= FSPEC_FAMILY; + strncpy (ptn->family, f, sizeof ptn->family - 1); +} + +void +BFont_populate_plain_family (struct haiku_font_pattern *ptn) +{ + font_family f; + font_style s; + be_plain_font->GetFamilyAndStyle (&f, &s); + + ptn->specified |= FSPEC_FAMILY; + strncpy (ptn->family, f, sizeof ptn->family - 1); +} + +int +BFont_string_width (void *font, const char *utf8) +{ + return ((BFont *) font)->StringWidth (utf8); +} diff --git a/src/haiku_io.c b/src/haiku_io.c new file mode 100644 index 00000000000..c152d9b086a --- /dev/null +++ b/src/haiku_io.c @@ -0,0 +1,207 @@ +/* Haiku window system support. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include +#include + +#include + +#include "haiku_support.h" +#include "lisp.h" +#include "haikuterm.h" +#include "blockinput.h" + +#define PORT_CAP 1200 + +/* The port used to send messages from the application thread to + Emacs. */ +port_id port_application_to_emacs; + +void +haiku_io_init (void) +{ + port_application_to_emacs = create_port (PORT_CAP, "application emacs port"); +} + +static ssize_t +haiku_len (enum haiku_event_type type) +{ + switch (type) + { + case QUIT_REQUESTED: + return sizeof (struct haiku_quit_requested_event); + case FRAME_RESIZED: + return sizeof (struct haiku_resize_event); + case FRAME_EXPOSED: + return sizeof (struct haiku_expose_event); + case KEY_DOWN: + case KEY_UP: + return sizeof (struct haiku_key_event); + case ACTIVATION: + return sizeof (struct haiku_activation_event); + case MOUSE_MOTION: + return sizeof (struct haiku_mouse_motion_event); + case BUTTON_DOWN: + case BUTTON_UP: + return sizeof (struct haiku_button_event); + case ICONIFICATION: + return sizeof (struct haiku_iconification_event); + case MOVE_EVENT: + return sizeof (struct haiku_move_event); + case SCROLL_BAR_VALUE_EVENT: + return sizeof (struct haiku_scroll_bar_value_event); + case SCROLL_BAR_DRAG_EVENT: + return sizeof (struct haiku_scroll_bar_drag_event); + case WHEEL_MOVE_EVENT: + return sizeof (struct haiku_wheel_move_event); + case MENU_BAR_RESIZE: + return sizeof (struct haiku_menu_bar_resize_event); + case MENU_BAR_OPEN: + case MENU_BAR_CLOSE: + return sizeof (struct haiku_menu_bar_state_event); + case MENU_BAR_SELECT_EVENT: + return sizeof (struct haiku_menu_bar_select_event); + case FILE_PANEL_EVENT: + return sizeof (struct haiku_file_panel_event); + case MENU_BAR_HELP_EVENT: + return sizeof (struct haiku_menu_bar_help_event); + case ZOOM_EVENT: + return sizeof (struct haiku_zoom_event); + case REFS_EVENT: + return sizeof (struct haiku_refs_event); + case APP_QUIT_REQUESTED_EVENT: + return sizeof (struct haiku_app_quit_requested_event); + } + + emacs_abort (); +} + +/* Read the size of the next message into len, returning -1 if the + query fails or there is no next message. */ +void +haiku_read_size (ssize_t *len) +{ + port_id from = port_application_to_emacs; + ssize_t size; + + size = port_buffer_size_etc (from, B_TIMEOUT, 0); + + if (size < B_OK) + *len = -1; + else + *len = size; +} + +/* Read the next message into BUF, putting its type into TYPE, + assuming the message is at most LEN long. Return 0 if successful + and -1 if the read fails. */ +int +haiku_read (enum haiku_event_type *type, void *buf, ssize_t len) +{ + int32 typ; + port_id from = port_application_to_emacs; + + if (read_port (from, &typ, buf, len) < B_OK) + return -1; + + *type = (enum haiku_event_type) typ; + eassert (len >= haiku_len (typ)); + return 0; +} + +/* The same as haiku_read, but time out after TIMEOUT microseconds. + Input is blocked when an attempt to read is in progress. */ +int +haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len, + time_t timeout) +{ + int32 typ; + port_id from = port_application_to_emacs; + + block_input (); + if (read_port_etc (from, &typ, buf, len, + B_TIMEOUT, (bigtime_t) timeout) < B_OK) + { + unblock_input (); + return -1; + } + unblock_input (); + *type = (enum haiku_event_type) typ; + eassert (len >= haiku_len (typ)); + return 0; +} + +/* Write a message with type TYPE into BUF. */ +int +haiku_write (enum haiku_event_type type, void *buf) +{ + port_id to = port_application_to_emacs; + + if (write_port (to, (int32_t) type, buf, haiku_len (type)) < B_OK) + return -1; + + kill (getpid (), SIGPOLL); + + return 0; +} + +int +haiku_write_without_signal (enum haiku_event_type type, void *buf) +{ + port_id to = port_application_to_emacs; + + if (write_port (to, (int32_t) type, buf, haiku_len (type)) < B_OK) + return -1; + + return 0; +} + +void +haiku_io_init_in_app_thread (void) +{ + sigset_t set; + sigfillset (&set); + + if (pthread_sigmask (SIG_BLOCK, &set, NULL)) + perror ("pthread_sigmask"); +} + +/* Record an unwind protect from C++ code. */ +void +record_c_unwind_protect_from_cxx (void (*fn) (void *), void *r) +{ + record_unwind_protect_ptr (fn, r); +} + +/* SPECPDL_IDX that is safe from C++ code. */ +ptrdiff_t +c_specpdl_idx_from_cxx (void) +{ + return SPECPDL_INDEX (); +} + +/* unbind_to (IDX, Qnil), but safe from C++ code. */ +void +c_unbind_to_nil_from_cxx (ptrdiff_t idx) +{ + unbind_to (idx, Qnil); +} diff --git a/src/haiku_select.cc b/src/haiku_select.cc new file mode 100644 index 00000000000..6cd6ee879e5 --- /dev/null +++ b/src/haiku_select.cc @@ -0,0 +1,229 @@ +/* Haiku window system selection support. Hey Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include + +#include +#include + +#include "haikuselect.h" + + +static BClipboard *primary = NULL; +static BClipboard *secondary = NULL; +static BClipboard *system_clipboard = NULL; + +int selection_state_flag; + +static char * +BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len) +{ + if (!cb->Lock ()) + return 0; + + BMessage *dat = cb->Data (); + if (!dat) + { + cb->Unlock (); + return 0; + } + + const char *ptr; + ssize_t bt; + dat->FindData (type, B_MIME_TYPE, (const void **) &ptr, &bt); + + if (!ptr) + { + cb->Unlock (); + return NULL; + } + + if (len) + *len = bt; + + cb->Unlock (); + + return strndup (ptr, bt); +} + +static void +BClipboard_get_targets (BClipboard *cb, char **buf, int buf_size) +{ + BMessage *data; + char *name; + int32 count_found; + type_code type; + int32 i; + int index; + + if (!cb->Lock ()) + { + buf[0] = NULL; + return; + } + + data = cb->Data (); + index = 0; + + if (!data) + { + buf[0] = NULL; + cb->Unlock (); + return; + } + + for (i = 0; (data->GetInfo (B_ANY_TYPE, i, &name, + &type, &count_found) + == B_OK); ++i) + { + if (type == B_MIME_TYPE) + { + if (index < (buf_size - 1)) + { + buf[index++] = strdup (name); + + if (!buf[index - 1]) + break; + } + } + } + + buf[index] = NULL; + + cb->Unlock (); +} + +static void +BClipboard_set_data (BClipboard *cb, const char *type, const char *dat, + ssize_t len, bool clear) +{ + if (!cb->Lock ()) + return; + + if (clear) + cb->Clear (); + + BMessage *mdat = cb->Data (); + if (!mdat) + { + cb->Unlock (); + return; + } + + if (dat) + { + if (mdat->ReplaceData (type, B_MIME_TYPE, dat, len) + == B_NAME_NOT_FOUND) + mdat->AddData (type, B_MIME_TYPE, dat, len); + } + else + mdat->RemoveName (type); + cb->Commit (); + cb->Unlock (); +} + +char * +BClipboard_find_system_data (const char *type, ssize_t *len) +{ + if (!system_clipboard) + return 0; + + return BClipboard_find_data (system_clipboard, type, len); +} + +char * +BClipboard_find_primary_selection_data (const char *type, ssize_t *len) +{ + if (!primary) + return 0; + + return BClipboard_find_data (primary, type, len); +} + +char * +BClipboard_find_secondary_selection_data (const char *type, ssize_t *len) +{ + if (!secondary) + return 0; + + return BClipboard_find_data (secondary, type, len); +} + +void +BClipboard_set_system_data (const char *type, const char *data, + ssize_t len, bool clear) +{ + if (!system_clipboard) + return; + + BClipboard_set_data (system_clipboard, type, data, len, clear); +} + +void +BClipboard_set_primary_selection_data (const char *type, const char *data, + ssize_t len, bool clear) +{ + if (!primary) + return; + + BClipboard_set_data (primary, type, data, len, clear); +} + +void +BClipboard_set_secondary_selection_data (const char *type, const char *data, + ssize_t len, bool clear) +{ + if (!secondary) + return; + + BClipboard_set_data (secondary, type, data, len, clear); +} + +void +BClipboard_free_data (void *ptr) +{ + std::free (ptr); +} + +void +BClipboard_system_targets (char **buf, int len) +{ + BClipboard_get_targets (system_clipboard, buf, len); +} + +void +BClipboard_primary_targets (char **buf, int len) +{ + BClipboard_get_targets (primary, buf, len); +} + +void +BClipboard_secondary_targets (char **buf, int len) +{ + BClipboard_get_targets (secondary, buf, len); +} + +void +init_haiku_select (void) +{ + system_clipboard = new BClipboard ("system"); + primary = new BClipboard ("primary"); + secondary = new BClipboard ("secondary"); +} diff --git a/src/haiku_support.cc b/src/haiku_support.cc new file mode 100644 index 00000000000..d6d7967524c --- /dev/null +++ b/src/haiku_support.cc @@ -0,0 +1,2930 @@ +/* Haiku window system support. Hey, Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +#include +#include + +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include +#include +#include + +#include +#include +#include + +#include + +#include +#include +#include +#include +#include +#include + +#include + +#ifdef USE_BE_CAIRO +#include +#endif + +#include "haiku_support.h" + +#define SCROLL_BAR_UPDATE 3000 + +static color_space dpy_color_space = B_NO_COLOR_SPACE; +static key_map *key_map = NULL; +static char *key_chars = NULL; +static BLocker key_map_lock; + +extern "C" +{ + extern _Noreturn void emacs_abort (void); + /* Also defined in haikuterm.h. */ + extern void be_app_quit (void); +} + +static thread_id app_thread; + +_Noreturn void +gui_abort (const char *msg) +{ + fprintf (stderr, "Abort in GUI code: %s\n", msg); + fprintf (stderr, "Under Haiku, Emacs cannot recover from errors in GUI code\n"); + fprintf (stderr, "App Server disconnects usually manifest as bitmap " + "initialization failures or lock failures."); + emacs_abort (); +} + +#ifdef USE_BE_CAIRO +static cairo_format_t +cairo_format_from_color_space (color_space space) +{ + switch (space) + { + case B_RGBA32: + return CAIRO_FORMAT_ARGB32; + case B_RGB32: + return CAIRO_FORMAT_RGB24; + case B_RGB16: + return CAIRO_FORMAT_RGB16_565; + case B_GRAY8: + return CAIRO_FORMAT_A8; + case B_GRAY1: + return CAIRO_FORMAT_A1; + default: + gui_abort ("Unsupported color space"); + } +} +#endif + +static void +map_key (char *chars, int32 offset, uint32_t *c) +{ + int size = chars[offset++]; + switch (size) + { + case 0: + break; + + case 1: + *c = chars[offset]; + break; + + default: + { + char str[5]; + int i = (size <= 4) ? size : 4; + strncpy (str, &(chars[offset]), i); + str[i] = '0'; + *c = BUnicodeChar::FromUTF8 ((char *) &str); + break; + } + } +} + +static void +map_shift (uint32_t kc, uint32_t *ch) +{ + if (!key_map_lock.Lock ()) + gui_abort ("Failed to lock keymap"); + if (!key_map) + get_key_map (&key_map, &key_chars); + if (!key_map) + return; + if (kc >= 128) + return; + + int32_t m = key_map->shift_map[kc]; + map_key (key_chars, m, ch); + key_map_lock.Unlock (); +} + +static void +map_normal (uint32_t kc, uint32_t *ch) +{ + if (!key_map_lock.Lock ()) + gui_abort ("Failed to lock keymap"); + if (!key_map) + get_key_map (&key_map, &key_chars); + if (!key_map) + return; + if (kc >= 128) + return; + + int32_t m = key_map->normal_map[kc]; + map_key (key_chars, m, ch); + key_map_lock.Unlock (); +} + +class Emacs : public BApplication +{ +public: + Emacs () : BApplication ("application/x-vnd.GNU-emacs") + { + } + + void + AboutRequested (void) + { + BAlert *about = new BAlert (PACKAGE_NAME, + PACKAGE_STRING + "\nThe extensible, self-documenting, real-time display editor.", + "Close"); + about->Go (); + } + + bool + QuitRequested (void) + { + struct haiku_app_quit_requested_event rq; + haiku_write (APP_QUIT_REQUESTED_EVENT, &rq); + return 0; + } + + void + RefsReceived (BMessage *msg) + { + struct haiku_refs_event rq; + entry_ref ref; + BEntry entry; + BPath path; + int32 cookie = 0; + int32 x, y; + void *window; + + if ((msg->FindPointer ("window", 0, &window) != B_OK) + || (msg->FindInt32 ("x", 0, &x) != B_OK) + || (msg->FindInt32 ("y", 0, &y) != B_OK)) + return; + + rq.window = window; + rq.x = x; + rq.y = y; + + while (msg->FindRef ("refs", cookie++, &ref) == B_OK) + { + if (entry.SetTo (&ref, 0) == B_OK + && entry.GetPath (&path) == B_OK) + { + rq.ref = strdup (path.Path ()); + haiku_write (REFS_EVENT, &rq); + } + } + } +}; + +class EmacsWindow : public BDirectWindow +{ +public: + struct child_frame + { + struct child_frame *next; + int xoff, yoff; + EmacsWindow *window; + } *subset_windows = NULL; + + EmacsWindow *parent = NULL; + BRect pre_fullscreen_rect; + BRect pre_zoom_rect; + int x_before_zoom = INT_MIN; + int y_before_zoom = INT_MIN; + int fullscreen_p = 0; + int zoomed_p = 0; + int shown_flag = 0; + +#ifdef USE_BE_CAIRO + BLocker surface_lock; + cairo_surface_t *cr_surface = NULL; +#endif + + EmacsWindow () : BDirectWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, + B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) + { + + } + + ~EmacsWindow () + { + struct child_frame *next; + for (struct child_frame *f = subset_windows; f; f = next) + { + f->window->Unparent (); + next = f->next; + delete f; + } + + if (this->parent) + UnparentAndUnlink (); + +#ifdef USE_BE_CAIRO + if (!surface_lock.Lock ()) + gui_abort ("Failed to lock cairo surface"); + if (cr_surface) + { + cairo_surface_destroy (cr_surface); + cr_surface = NULL; + } + surface_lock.Unlock (); +#endif + } + + void + UpwardsSubset (EmacsWindow *w) + { + for (; w; w = w->parent) + AddToSubset (w); + } + + void + UpwardsSubsetChildren (EmacsWindow *w) + { + UpwardsSubset (w); + for (struct child_frame *f = subset_windows; f; + f = f->next) + f->window->UpwardsSubsetChildren (w); + } + + void + UpwardsUnSubset (EmacsWindow *w) + { + for (; w; w = w->parent) + RemoveFromSubset (w); + } + + void + UpwardsUnSubsetChildren (EmacsWindow *w) + { + UpwardsUnSubset (w); + for (struct child_frame *f = subset_windows; f; + f = f->next) + f->window->UpwardsUnSubsetChildren (w); + } + + void + Unparent (void) + { + this->SetFeel (B_NORMAL_WINDOW_FEEL); + UpwardsUnSubsetChildren (parent); + this->RemoveFromSubset (this); + this->parent = NULL; + if (fullscreen_p) + { + fullscreen_p = 0; + MakeFullscreen (1); + } + } + + void + UnparentAndUnlink (void) + { + this->parent->UnlinkChild (this); + this->Unparent (); + } + + void + UnlinkChild (EmacsWindow *window) + { + struct child_frame *last = NULL; + struct child_frame *tem = subset_windows; + + for (; tem; last = tem, tem = tem->next) + { + if (tem->window == window) + { + if (last) + last->next = tem->next; + if (tem == subset_windows) + subset_windows = NULL; + delete tem; + return; + } + } + + gui_abort ("Failed to unlink child frame"); + } + + void + ParentTo (EmacsWindow *window) + { + if (this->parent) + UnparentAndUnlink (); + + this->parent = window; + this->SetFeel (B_FLOATING_SUBSET_WINDOW_FEEL); + this->AddToSubset (this); + if (!IsHidden () && this->parent) + UpwardsSubsetChildren (parent); + if (fullscreen_p) + { + fullscreen_p = 0; + MakeFullscreen (1); + } + this->Sync (); + window->LinkChild (this); + } + + void + LinkChild (EmacsWindow *window) + { + struct child_frame *f = new struct child_frame; + + for (struct child_frame *f = subset_windows; f; + f = f->next) + { + if (window == f->window) + gui_abort ("Trying to link a child frame that is already present"); + } + + f->window = window; + f->next = subset_windows; + f->xoff = -1; + f->yoff = -1; + + subset_windows = f; + } + + void + DoMove (struct child_frame *f) + { + BRect frame = this->Frame (); + f->window->MoveTo (frame.left + f->xoff, + frame.top + f->yoff); + this->Sync (); + } + + void + DoUpdateWorkspace (struct child_frame *f) + { + f->window->SetWorkspaces (this->Workspaces ()); + } + + void + MoveChild (EmacsWindow *window, int xoff, int yoff, + int weak_p) + { + for (struct child_frame *f = subset_windows; f; + f = f->next) + { + if (window == f->window) + { + f->xoff = xoff; + f->yoff = yoff; + if (!weak_p) + DoMove (f); + return; + } + } + + gui_abort ("Trying to move a child frame that doesn't exist"); + } + + void + WindowActivated (bool activated) + { + struct haiku_activation_event rq; + rq.window = this; + rq.activated_p = activated; + + haiku_write (ACTIVATION, &rq); + } + + void + DirectConnected (direct_buffer_info *info) + { +#ifdef USE_BE_CAIRO + if (!surface_lock.Lock ()) + gui_abort ("Failed to lock window direct cr surface"); + if (cr_surface) + { + cairo_surface_destroy (cr_surface); + cr_surface = NULL; + } + + if (info->buffer_state != B_DIRECT_STOP) + { + int left, top, right, bottom; + left = info->clip_bounds.left; + top = info->clip_bounds.top; + right = info->clip_bounds.right; + bottom = info->clip_bounds.bottom; + + unsigned char *bits = (unsigned char *) info->bits; + if ((info->bits_per_pixel % 8) == 0) + { + bits += info->bytes_per_row * top; + bits += (left * info->bits_per_pixel / 8); + cr_surface = cairo_image_surface_create_for_data + (bits, + cairo_format_from_color_space (info->pixel_format), + right - left + 1, + bottom - top + 1, + info->bytes_per_row); + } + } + surface_lock.Unlock (); +#endif + } + + void + MessageReceived (BMessage *msg) + { + int32 old_what = 0; + + if (msg->WasDropped ()) + { + entry_ref ref; + BPoint whereto; + + if (msg->FindRef ("refs", &ref) == B_OK) + { + msg->what = B_REFS_RECEIVED; + msg->AddPointer ("window", this); + if (msg->FindPoint ("_drop_point_", &whereto) == B_OK) + { + this->ConvertFromScreen (&whereto); + msg->AddInt32 ("x", whereto.x); + msg->AddInt32 ("y", whereto.y); + } + be_app->PostMessage (msg); + msg->SendReply (B_OK); + } + } + else if (msg->GetPointer ("menuptr")) + { + struct haiku_menu_bar_select_event rq; + rq.window = this; + rq.ptr = (void *) msg->GetPointer ("menuptr"); + haiku_write (MENU_BAR_SELECT_EVENT, &rq); + } + else if (msg->what == 'FPSE' + || ((msg->FindInt32 ("old_what", &old_what) == B_OK + && old_what == 'FPSE'))) + { + struct haiku_file_panel_event rq; + BEntry entry; + BPath path; + entry_ref ref; + + rq.ptr = NULL; + + if (msg->FindRef ("refs", &ref) == B_OK && + entry.SetTo (&ref, 0) == B_OK && + entry.GetPath (&path) == B_OK) + { + const char *str_path = path.Path (); + if (str_path) + rq.ptr = strdup (str_path); + } + + if (msg->FindRef ("directory", &ref), + entry.SetTo (&ref, 0) == B_OK && + entry.GetPath (&path) == B_OK) + { + const char *name = msg->GetString ("name"); + const char *str_path = path.Path (); + + if (name) + { + char str_buf[std::strlen (str_path) + + std::strlen (name) + 2]; + snprintf ((char *) &str_buf, + std::strlen (str_path) + + std::strlen (name) + 2, "%s/%s", + str_path, name); + rq.ptr = strdup (str_buf); + } + } + + haiku_write (FILE_PANEL_EVENT, &rq); + } + else + BDirectWindow::MessageReceived (msg); + } + + void + DispatchMessage (BMessage *msg, BHandler *handler) + { + if (msg->what == B_KEY_DOWN || msg->what == B_KEY_UP) + { + struct haiku_key_event rq; + rq.window = this; + + int32_t code = msg->GetInt32 ("raw_char", 0); + + rq.modifiers = 0; + uint32_t mods = modifiers (); + + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + rq.mb_char = code; + rq.kc = msg->GetInt32 ("key", -1); + rq.unraw_mb_char = + BUnicodeChar::FromUTF8 (msg->GetString ("bytes")); + + if ((mods & B_SHIFT_KEY) && rq.kc >= 0) + map_shift (rq.kc, &rq.unraw_mb_char); + else if (rq.kc >= 0) + map_normal (rq.kc, &rq.unraw_mb_char); + + haiku_write (msg->what == B_KEY_DOWN ? KEY_DOWN : KEY_UP, &rq); + } + else if (msg->what == B_MOUSE_WHEEL_CHANGED) + { + struct haiku_wheel_move_event rq; + rq.window = this; + rq.modifiers = 0; + + uint32_t mods = modifiers (); + + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + float dx, dy; + if (msg->FindFloat ("be:wheel_delta_x", &dx) == B_OK && + msg->FindFloat ("be:wheel_delta_y", &dy) == B_OK) + { + rq.delta_x = dx; + rq.delta_y = dy; + + haiku_write (WHEEL_MOVE_EVENT, &rq); + }; + } + else + BDirectWindow::DispatchMessage (msg, handler); + } + + void + MenusBeginning () + { + struct haiku_menu_bar_state_event rq; + rq.window = this; + + haiku_write (MENU_BAR_OPEN, &rq); + } + + void + MenusEnded () + { + struct haiku_menu_bar_state_event rq; + rq.window = this; + + haiku_write (MENU_BAR_CLOSE, &rq); + } + + void + FrameResized (float newWidth, float newHeight) + { + struct haiku_resize_event rq; + rq.window = this; + rq.px_heightf = newHeight + 1.0f; + rq.px_widthf = newWidth + 1.0f; + + haiku_write (FRAME_RESIZED, &rq); + BDirectWindow::FrameResized (newWidth, newHeight); + } + + void + FrameMoved (BPoint newPosition) + { + struct haiku_move_event rq; + rq.window = this; + rq.x = std::lrint (newPosition.x); + rq.y = std::lrint (newPosition.y); + + haiku_write (MOVE_EVENT, &rq); + + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoMove (f); + BDirectWindow::FrameMoved (newPosition); + } + + void + WorkspacesChanged (uint32_t old, uint32_t n) + { + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoUpdateWorkspace (f); + } + + void + EmacsMoveTo (int x, int y) + { + if (!this->parent) + this->MoveTo (x, y); + else + this->parent->MoveChild (this, x, y, 0); + } + + bool + QuitRequested () + { + struct haiku_quit_requested_event rq; + rq.window = this; + haiku_write (QUIT_REQUESTED, &rq); + return false; + } + + void + Minimize (bool minimized_p) + { + BDirectWindow::Minimize (minimized_p); + struct haiku_iconification_event rq; + rq.window = this; + rq.iconified_p = !parent && minimized_p; + + haiku_write (ICONIFICATION, &rq); + } + + void + EmacsHide (void) + { + if (this->IsHidden ()) + return; + Hide (); + if (this->parent) + UpwardsUnSubsetChildren (this->parent); + } + + void + EmacsShow (void) + { + if (!this->IsHidden ()) + return; + if (this->parent) + shown_flag = 1; + Show (); + if (this->parent) + UpwardsSubsetChildren (this->parent); + } + + void + Zoom (BPoint o, float w, float h) + { + struct haiku_zoom_event rq; + rq.window = this; + + rq.x = o.x; + rq.y = o.y; + + rq.width = w + 1; + rq.height = h + 1; + + if (fullscreen_p) + MakeFullscreen (0); + + if (o.x != x_before_zoom || + o.y != y_before_zoom) + { + x_before_zoom = Frame ().left; + y_before_zoom = Frame ().top; + pre_zoom_rect = Frame (); + zoomed_p = 1; + haiku_write (ZOOM_EVENT, &rq); + } + else + { + zoomed_p = 0; + x_before_zoom = y_before_zoom = INT_MIN; + } + + BDirectWindow::Zoom (o, w, h); + } + + void + UnZoom (void) + { + if (!zoomed_p) + return; + zoomed_p = 0; + + EmacsMoveTo (pre_zoom_rect.left, pre_zoom_rect.top); + ResizeTo (pre_zoom_rect.Width (), + pre_zoom_rect.Height ()); + } + + void + GetParentWidthHeight (int *width, int *height) + { + if (parent) + { + *width = parent->Frame ().Width (); + *height = parent->Frame ().Height (); + } + else + { + BScreen s (this); + *width = s.Frame ().Width (); + *height = s.Frame ().Height (); + } + } + + void + OffsetChildRect (BRect *r, EmacsWindow *c) + { + for (struct child_frame *f; f; f = f->next) + if (f->window == c) + { + r->top -= f->yoff; + r->bottom -= f->yoff; + r->left -= f->xoff; + r->right -= f->xoff; + return; + } + + gui_abort ("Trying to calculate offsets for a child frame that doesn't exist"); + } + + void + MakeFullscreen (int make_fullscreen_p) + { + BScreen screen (this); + + if (!screen.IsValid ()) + gui_abort ("Trying to make a window fullscreen without a screen"); + + if (make_fullscreen_p == fullscreen_p) + return; + + fullscreen_p = make_fullscreen_p; + uint32 flags = Flags (); + if (fullscreen_p) + { + if (zoomed_p) + UnZoom (); + + flags |= B_NOT_MOVABLE | B_NOT_ZOOMABLE; + pre_fullscreen_rect = Frame (); + if (parent) + parent->OffsetChildRect (&pre_fullscreen_rect, this); + + int w, h; + EmacsMoveTo (0, 0); + GetParentWidthHeight (&w, &h); + ResizeTo (w, h); + } + else + { + flags &= ~(B_NOT_MOVABLE | B_NOT_ZOOMABLE); + EmacsMoveTo (pre_fullscreen_rect.left, + pre_fullscreen_rect.top); + ResizeTo (pre_fullscreen_rect.Width (), + pre_fullscreen_rect.Height ()); + } + SetFlags (flags); + } +}; + +class EmacsMenuBar : public BMenuBar +{ +public: + EmacsMenuBar () : BMenuBar (BRect (0, 0, 0, 0), NULL) + { + } + + void + FrameResized (float newWidth, float newHeight) + { + struct haiku_menu_bar_resize_event rq; + rq.window = this->Window (); + rq.height = std::lrint (newHeight); + rq.width = std::lrint (newWidth); + + haiku_write (MENU_BAR_RESIZE, &rq); + BMenuBar::FrameResized (newWidth, newHeight); + } +}; + +class EmacsView : public BView +{ +public: + uint32_t visible_bell_color = 0; + uint32_t previous_buttons = 0; + int looper_locked_count = 0; + BRegion sb_region; + + BView *offscreen_draw_view = NULL; + BBitmap *offscreen_draw_bitmap_1 = NULL; + BBitmap *copy_bitmap = NULL; + +#ifdef USE_BE_CAIRO + cairo_surface_t *cr_surface = NULL; + BLocker cr_surface_lock; +#endif + + BPoint tt_absl_pos; + + color_space cspace; + + EmacsView () : BView (BRect (0, 0, 0, 0), "Emacs", B_FOLLOW_NONE, B_WILL_DRAW) + { + + } + + ~EmacsView () + { + TearDownDoubleBuffering (); + } + + void + AttachedToWindow (void) + { + cspace = B_RGBA32; + } + +#ifdef USE_BE_CAIRO + void + DetachCairoSurface (void) + { + if (!cr_surface_lock.Lock ()) + gui_abort ("Could not lock cr surface during detachment"); + if (!cr_surface) + gui_abort ("Trying to detach window cr surface when none exists"); + cairo_surface_destroy (cr_surface); + cr_surface = NULL; + cr_surface_lock.Unlock (); + } + + void + AttachCairoSurface (void) + { + if (!cr_surface_lock.Lock ()) + gui_abort ("Could not lock cr surface during attachment"); + if (cr_surface) + gui_abort ("Trying to attach cr surface when one already exists"); + cr_surface = cairo_image_surface_create_for_data + ((unsigned char *) offscreen_draw_bitmap_1->Bits (), + CAIRO_FORMAT_ARGB32, offscreen_draw_bitmap_1->Bounds ().Width (), + offscreen_draw_bitmap_1->Bounds ().Height (), + offscreen_draw_bitmap_1->BytesPerRow ()); + if (!cr_surface) + gui_abort ("Cr surface allocation failed for double-buffered view"); + cr_surface_lock.Unlock (); + } +#endif + + void + TearDownDoubleBuffering (void) + { + if (offscreen_draw_view) + { + if (Window ()) + ClearViewBitmap (); + if (copy_bitmap) + { + delete copy_bitmap; + copy_bitmap = NULL; + } + if (!looper_locked_count) + if (!offscreen_draw_view->LockLooper ()) + gui_abort ("Failed to lock offscreen draw view"); +#ifdef USE_BE_CAIRO + if (cr_surface) + DetachCairoSurface (); +#endif + offscreen_draw_view->RemoveSelf (); + delete offscreen_draw_view; + offscreen_draw_view = NULL; + delete offscreen_draw_bitmap_1; + offscreen_draw_bitmap_1 = NULL; + } + } + + void + AfterResize (void) + { + if (offscreen_draw_view) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper after resize"); + + if (!offscreen_draw_view->LockLooper ()) + gui_abort ("Failed to lock offscreen draw view after resize"); +#ifdef USE_BE_CAIRO + DetachCairoSurface (); +#endif + offscreen_draw_view->RemoveSelf (); + delete offscreen_draw_bitmap_1; + offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1); + if (offscreen_draw_bitmap_1->InitCheck () != B_OK) + gui_abort ("Offscreen draw bitmap initialization failed"); + + offscreen_draw_view->MoveTo (Frame ().left, Frame ().top); + offscreen_draw_view->ResizeTo (Frame ().Width (), Frame ().Height ()); + offscreen_draw_bitmap_1->AddChild (offscreen_draw_view); +#ifdef USE_BE_CAIRO + AttachCairoSurface (); +#endif + + if (looper_locked_count) + { + offscreen_draw_bitmap_1->Lock (); + } + + UnlockLooper (); + } + } + + void + Pulse (void) + { + visible_bell_color = 0; + SetFlags (Flags () & ~B_PULSE_NEEDED); + Window ()->SetPulseRate (0); + Invalidate (); + } + + void + Draw (BRect expose_bounds) + { + struct haiku_expose_event rq; + EmacsWindow *w = (EmacsWindow *) Window (); + + if (visible_bell_color > 0) + { + PushState (); + BView_SetHighColorForVisibleBell (this, visible_bell_color); + FillRect (Frame ()); + PopState (); + return; + } + + if (w->shown_flag) + { + PushState (); + SetDrawingMode (B_OP_ERASE); + FillRect (Frame ()); + PopState (); + return; + } + + if (!offscreen_draw_view) + { + if (sb_region.Contains (std::lrint (expose_bounds.left), + std::lrint (expose_bounds.top)) && + sb_region.Contains (std::lrint (expose_bounds.right), + std::lrint (expose_bounds.top)) && + sb_region.Contains (std::lrint (expose_bounds.left), + std::lrint (expose_bounds.bottom)) && + sb_region.Contains (std::lrint (expose_bounds.right), + std::lrint (expose_bounds.bottom))) + return; + + rq.x = std::floor (expose_bounds.left); + rq.y = std::floor (expose_bounds.top); + rq.width = std::ceil (expose_bounds.right - expose_bounds.left + 1); + rq.height = std::ceil (expose_bounds.bottom - expose_bounds.top + 1); + if (!rq.width) + rq.width = 1; + if (!rq.height) + rq.height = 1; + rq.window = this->Window (); + + haiku_write (FRAME_EXPOSED, &rq); + } + } + + void + DoVisibleBell (uint32_t color) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper during visible bell"); + visible_bell_color = color | (255 << 24); + SetFlags (Flags () | B_PULSE_NEEDED); + Window ()->SetPulseRate (100 * 1000); + Invalidate (); + UnlockLooper (); + } + + void + FlipBuffers (void) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper during buffer flip"); + if (!offscreen_draw_view) + gui_abort ("Failed to lock offscreen view during buffer flip"); + + offscreen_draw_view->Flush (); + offscreen_draw_view->Sync (); + + EmacsWindow *w = (EmacsWindow *) Window (); + w->shown_flag = 0; + + if (copy_bitmap && + copy_bitmap->Bounds () != offscreen_draw_bitmap_1->Bounds ()) + { + delete copy_bitmap; + copy_bitmap = NULL; + } + if (!copy_bitmap) + copy_bitmap = new BBitmap (offscreen_draw_bitmap_1); + else + copy_bitmap->ImportBits (offscreen_draw_bitmap_1); + + if (copy_bitmap->InitCheck () != B_OK) + gui_abort ("Failed to init copy bitmap during buffer flip"); + + SetViewBitmap (copy_bitmap, + Frame (), Frame (), B_FOLLOW_NONE, 0); + + Invalidate (); + UnlockLooper (); + return; + } + + void + SetUpDoubleBuffering (void) + { + if (!LockLooper ()) + gui_abort ("Failed to lock self setting up double buffering"); + if (offscreen_draw_view) + gui_abort ("Failed to lock offscreen view setting up double buffering"); + + offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1); + if (offscreen_draw_bitmap_1->InitCheck () != B_OK) + gui_abort ("Failed to init offscreen bitmap"); +#ifdef USE_BE_CAIRO + AttachCairoSurface (); +#endif + offscreen_draw_view = new BView (Frame (), NULL, B_FOLLOW_NONE, B_WILL_DRAW); + offscreen_draw_bitmap_1->AddChild (offscreen_draw_view); + + if (looper_locked_count) + { + if (!offscreen_draw_bitmap_1->Lock ()) + gui_abort ("Failed to lock bitmap after double buffering was set up."); + } + + UnlockLooper (); + Invalidate (); + } + + void + MouseMoved (BPoint point, uint32 transit, const BMessage *msg) + { + struct haiku_mouse_motion_event rq; + + rq.just_exited_p = transit == B_EXITED_VIEW; + rq.x = point.x; + rq.y = point.y; + rq.be_code = transit; + rq.window = this->Window (); + + if (ToolTip ()) + ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), + -(point.y - tt_absl_pos.y))); + + haiku_write (MOUSE_MOTION, &rq); + } + + void + MouseDown (BPoint point) + { + struct haiku_button_event rq; + uint32 buttons; + + this->GetMouse (&point, &buttons, false); + + rq.window = this->Window (); + rq.btn_no = 0; + + if (!(previous_buttons & B_PRIMARY_MOUSE_BUTTON) && + (buttons & B_PRIMARY_MOUSE_BUTTON)) + rq.btn_no = 0; + else if (!(previous_buttons & B_SECONDARY_MOUSE_BUTTON) && + (buttons & B_SECONDARY_MOUSE_BUTTON)) + rq.btn_no = 2; + else if (!(previous_buttons & B_TERTIARY_MOUSE_BUTTON) && + (buttons & B_TERTIARY_MOUSE_BUTTON)) + rq.btn_no = 1; + previous_buttons = buttons; + + rq.x = point.x; + rq.y = point.y; + + uint32_t mods = modifiers (); + + rq.modifiers = 0; + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + SetMouseEventMask (B_POINTER_EVENTS, B_LOCK_WINDOW_FOCUS); + + haiku_write (BUTTON_DOWN, &rq); + } + + void + MouseUp (BPoint point) + { + struct haiku_button_event rq; + uint32 buttons; + + this->GetMouse (&point, &buttons, false); + + rq.window = this->Window (); + rq.btn_no = 0; + + if ((previous_buttons & B_PRIMARY_MOUSE_BUTTON) + && !(buttons & B_PRIMARY_MOUSE_BUTTON)) + rq.btn_no = 0; + else if ((previous_buttons & B_SECONDARY_MOUSE_BUTTON) + && !(buttons & B_SECONDARY_MOUSE_BUTTON)) + rq.btn_no = 2; + else if ((previous_buttons & B_TERTIARY_MOUSE_BUTTON) + && !(buttons & B_TERTIARY_MOUSE_BUTTON)) + rq.btn_no = 1; + previous_buttons = buttons; + + rq.x = point.x; + rq.y = point.y; + + uint32_t mods = modifiers (); + + rq.modifiers = 0; + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + if (!buttons) + SetMouseEventMask (0, 0); + + haiku_write (BUTTON_UP, &rq); + } +}; + +class EmacsScrollBar : public BScrollBar +{ +public: + void *scroll_bar; + + EmacsScrollBar (int x, int y, int x1, int y1, bool horizontal_p) : + BScrollBar (BRect (x, y, x1, y1), NULL, NULL, 0, 0, horizontal_p ? + B_HORIZONTAL : B_VERTICAL) + { + BView *vw = (BView *) this; + vw->SetResizingMode (B_FOLLOW_NONE); + } + + void + MessageReceived (BMessage *msg) + { + if (msg->what == SCROLL_BAR_UPDATE) + { + this->SetRange (0, msg->GetInt32 ("emacs:range", 0)); + this->SetValue (msg->GetInt32 ("emacs:units", 0)); + } + + BScrollBar::MessageReceived (msg); + } + + void + ValueChanged (float new_value) + { + struct haiku_scroll_bar_value_event rq; + rq.scroll_bar = scroll_bar; + rq.position = new_value; + + haiku_write (SCROLL_BAR_VALUE_EVENT, &rq); + } + + void + MouseDown (BPoint pt) + { + struct haiku_scroll_bar_drag_event rq; + rq.dragging_p = 1; + rq.scroll_bar = scroll_bar; + + haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); + BScrollBar::MouseDown (pt); + } + + void + MouseUp (BPoint pt) + { + struct haiku_scroll_bar_drag_event rq; + rq.dragging_p = 0; + rq.scroll_bar = scroll_bar; + + haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); + BScrollBar::MouseUp (pt); + } +}; + +class EmacsTitleMenuItem : public BMenuItem +{ +public: + EmacsTitleMenuItem (const char *str) : BMenuItem (str, NULL) + { + SetEnabled (0); + } + + void + DrawContent (void) + { + BMenu *menu = Menu (); + + menu->PushState (); + menu->SetFont (be_bold_font); + BView_SetHighColorForVisibleBell (menu, 0); + BMenuItem::DrawContent (); + menu->PopState (); + } +}; + +class EmacsMenuItem : public BMenuItem +{ +public: + int menu_bar_id = -1; + void *wind_ptr = NULL; + char *key = NULL; + char *help = NULL; + + EmacsMenuItem (const char *ky, + const char *str, + const char *help, + BMessage *message = NULL) : BMenuItem (str, message) + { + if (ky) + { + key = strdup (ky); + if (!key) + gui_abort ("strdup failed"); + } + + if (help) + { + this->help = strdup (help); + if (!this->help) + gui_abort ("strdup failed"); + } + } + + ~EmacsMenuItem () + { + if (key) + free (key); + if (help) + free (help); + } + + void + DrawContent (void) + { + BMenu *menu = Menu (); + + BMenuItem::DrawContent (); + + if (key) + { + BRect r = menu->Frame (); + int w = menu->StringWidth (key); + menu->MovePenTo (BPoint (r.Width () - w - 4, + menu->PenLocation ().y)); + menu->DrawString (key); + } + } + + void + GetContentSize (float *w, float *h) + { + BMenuItem::GetContentSize (w, h); + if (Menu () && key) + *w += 4 + Menu ()->StringWidth (key); + } + + void + Highlight (bool highlight_p) + { + struct haiku_menu_bar_help_event rq; + + if (menu_bar_id >= 0) + { + rq.window = wind_ptr; + rq.mb_idx = highlight_p ? menu_bar_id : -1; + + haiku_write (MENU_BAR_HELP_EVENT, &rq); + } + else if (help) + { + Menu ()->SetToolTip (highlight_p ? help : NULL); + } + + BMenuItem::Highlight (highlight_p); + } +}; + +class EmacsPopUpMenu : public BPopUpMenu +{ +public: + EmacsPopUpMenu (const char *name) : BPopUpMenu (name, 0) + { + + } + + void + FrameResized (float w, float h) + { + Invalidate (); + BPopUpMenu::FrameResized (w, h); + } +}; + +static int32 +start_running_application (void *data) +{ + haiku_io_init_in_app_thread (); + + if (!((Emacs *) data)->Lock ()) + gui_abort ("Failed to lock application"); + + ((Emacs *) data)->Run (); + ((Emacs *) data)->Unlock (); + return 0; +} + +/* Take BITMAP, a reference to a BBitmap, and return a pointer to its + data. */ +void * +BBitmap_data (void *bitmap) +{ + return ((BBitmap *) bitmap)->Bits (); +} + +/* Convert bitmap if required, placing the new bitmap in NEW_BITMAP, + and return non-null if bitmap was successfully converted. Bitmaps + should be freed with `BBitmap_free'. */ +int +BBitmap_convert (void *_bitmap, void **new_bitmap) +{ + BBitmap *bitmap = (BBitmap *) _bitmap; + if (bitmap->ColorSpace () == B_RGBA32) + return -1; + BRect bounds = bitmap->Bounds (); + BBitmap *bmp = new (std::nothrow) BBitmap (bounds, B_RGBA32); + if (!bmp || bmp->InitCheck () != B_OK) + { + if (bmp) + delete bmp; + return 0; + } + if (bmp->ImportBits (bitmap) != B_OK) + { + delete bmp; + return 0; + } + *(BBitmap **) new_bitmap = bmp; + return 1; +} + +void +BBitmap_free (void *bitmap) +{ + delete (BBitmap *) bitmap; +} + +/* Create new bitmap in RGB32 format, or in GRAY1 if MONO_P is + non-zero. */ +void * +BBitmap_new (int width, int height, int mono_p) +{ + BBitmap *bn = new (std::nothrow) BBitmap (BRect (0, 0, width - 1, height - 1), + mono_p ? B_GRAY1 : B_RGB32); + + return bn->InitCheck () == B_OK ? (void *) bn : (void *) (delete bn, NULL); +} + +void +BBitmap_dimensions (void *bitmap, int *left, int *top, + int *right, int *bottom, + int32_t *bytes_per_row, int *mono_p) +{ + BRect rect = ((BBitmap *) bitmap)->Bounds (); + *left = rect.left; + *top = rect.top; + *right = rect.right; + *bottom = rect.bottom; + + *bytes_per_row = ((BBitmap *) bitmap)->BytesPerRow (); + *mono_p = (((BBitmap *) bitmap)->ColorSpace () == B_GRAY1); +} + +/* Set up an application and return it. If starting the application + thread fails, abort Emacs. */ +void * +BApplication_setup (void) +{ + if (be_app) + return be_app; + thread_id id; + Emacs *app; + + app = new Emacs; + app->Unlock (); + if ((id = spawn_thread (start_running_application, "Emacs app thread", + B_DEFAULT_MEDIA_PRIORITY, app)) < 0) + gui_abort ("spawn_thread failed"); + + resume_thread (id); + + app_thread = id; + return app; +} + +/* Set up and return a window with its view put in VIEW. */ +void * +BWindow_new (void *_view) +{ + BWindow *window = new (std::nothrow) EmacsWindow; + BView **v = (BView **) _view; + if (!window) + { + *v = NULL; + return window; + } + + BView *vw = new (std::nothrow) EmacsView; + if (!vw) + { + *v = NULL; + window->Lock (); + window->Quit (); + return NULL; + } + window->AddChild (vw); + *v = vw; + return window; +} + +void +BWindow_quit (void *window) +{ + ((BWindow *) window)->Lock (); + ((BWindow *) window)->Quit (); +} + +/* Set WINDOW's offset to X, Y. */ +void +BWindow_set_offset (void *window, int x, int y) +{ + BWindow *wn = (BWindow *) window; + EmacsWindow *w = dynamic_cast (wn); + if (w) + { + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper setting offset"); + w->EmacsMoveTo (x, y); + w->UnlockLooper (); + } + else + wn->MoveTo (x, y); +} + +/* Iconify WINDOW. */ +void +BWindow_iconify (void *window) +{ + if (((BWindow *) window)->IsHidden ()) + BWindow_set_visible (window, true); + ((BWindow *) window)->Minimize (true); +} + +/* Show or hide WINDOW. */ +void +BWindow_set_visible (void *window, int visible_p) +{ + EmacsWindow *win = (EmacsWindow *) window; + if (visible_p) + { + if (win->IsMinimized ()) + win->Minimize (false); + win->EmacsShow (); + } + else if (!win->IsHidden ()) + { + if (win->IsMinimized ()) + win->Minimize (false); + win->EmacsHide (); + } + win->Sync (); +} + +/* Change the title of WINDOW to the multibyte string TITLE. */ +void +BWindow_retitle (void *window, const char *title) +{ + ((BWindow *) window)->SetTitle (title); +} + +/* Resize WINDOW to WIDTH by HEIGHT. */ +void +BWindow_resize (void *window, int width, int height) +{ + ((BWindow *) window)->ResizeTo (width, height); +} + +/* Activate WINDOW, making it the subject of keyboard focus and + bringing it to the front of the screen. */ +void +BWindow_activate (void *window) +{ + ((BWindow *) window)->Activate (); +} + +/* Return the pixel dimensions of the main screen in WIDTH and + HEIGHT. */ +void +BScreen_px_dim (int *width, int *height) +{ + BScreen screen; + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + BRect frame = screen.Frame (); + + *width = frame.right - frame.left; + *height = frame.bottom - frame.top; +} + +/* Resize VIEW to WIDTH, HEIGHT. */ +void +BView_resize_to (void *view, int width, int height) +{ + EmacsView *vw = (EmacsView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view for resize"); + vw->ResizeTo (width, height); + vw->AfterResize (); + vw->UnlockLooper (); +} + +void * +BCursor_create_default (void) +{ + return new BCursor (B_CURSOR_ID_SYSTEM_DEFAULT); +} + +void * +BCursor_create_modeline (void) +{ + return new BCursor (B_CURSOR_ID_CONTEXT_MENU); +} + +void * +BCursor_from_id (enum haiku_cursor cursor) +{ + return new BCursor ((enum BCursorID) cursor); +} + +void * +BCursor_create_i_beam (void) +{ + return new BCursor (B_CURSOR_ID_I_BEAM); +} + +void * +BCursor_create_progress_cursor (void) +{ + return new BCursor (B_CURSOR_ID_PROGRESS); +} + +void * +BCursor_create_grab (void) +{ + return new BCursor (B_CURSOR_ID_GRAB); +} + +void +BCursor_delete (void *cursor) +{ + delete (BCursor *) cursor; +} + +void +BView_set_view_cursor (void *view, void *cursor) +{ + if (!((BView *) view)->LockLooper ()) + gui_abort ("Failed to lock view setting cursor"); + ((BView *) view)->SetViewCursor ((BCursor *) cursor); + ((BView *) view)->UnlockLooper (); +} + +void +BWindow_Flush (void *window) +{ + ((BWindow *) window)->Flush (); +} + +/* Map the keycode KC, storing the result in CODE and 1 in + NON_ASCII_P if it should be used. */ +void +BMapKey (uint32_t kc, int *non_ascii_p, unsigned *code) +{ + if (*code == 10 && kc != 0x42) + { + *code = XK_Return; + *non_ascii_p = 1; + return; + } + + switch (kc) + { + default: + *non_ascii_p = 0; + if (kc < 0xe && kc > 0x1) + { + *code = XK_F1 + kc - 2; + *non_ascii_p = 1; + } + return; + case 0x1e: + *code = XK_BackSpace; + break; + case 0x61: + *code = XK_Left; + break; + case 0x63: + *code = XK_Right; + break; + case 0x57: + *code = XK_Up; + break; + case 0x62: + *code = XK_Down; + break; + case 0x64: + *code = XK_Insert; + break; + case 0x65: + *code = XK_Delete; + break; + case 0x37: + *code = XK_Home; + break; + case 0x58: + *code = XK_End; + break; + case 0x39: + *code = XK_Page_Up; + break; + case 0x5a: + *code = XK_Page_Down; + break; + case 0x1: + *code = XK_Escape; + break; + case 0x68: + *code = XK_Menu; + break; + } + *non_ascii_p = 1; +} + +/* Make a scrollbar, attach it to VIEW's window, and return it. */ +void * +BScrollBar_make_for_view (void *view, int horizontal_p, + int x, int y, int x1, int y1, + void *scroll_bar_ptr) +{ + EmacsScrollBar *sb = new EmacsScrollBar (x, y, x1, y1, horizontal_p); + sb->scroll_bar = scroll_bar_ptr; + + BView *vw = (BView *) view; + BView *sv = (BView *) sb; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock scrollbar owner"); + vw->AddChild ((BView *) sb); + sv->WindowActivated (vw->Window ()->IsActive ()); + vw->UnlockLooper (); + return sb; +} + +void +BScrollBar_delete (void *sb) +{ + BView *view = (BView *) sb; + BView *pr = view->Parent (); + + if (!pr->LockLooper ()) + gui_abort ("Failed to lock scrollbar parent"); + pr->RemoveChild (view); + pr->UnlockLooper (); + + delete (EmacsScrollBar *) sb; +} + +void +BView_move_frame (void *view, int x, int y, int x1, int y1) +{ + BView *vw = (BView *) view; + + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view moving frame"); + vw->MoveTo (x, y); + vw->ResizeTo (x1 - x, y1 - y); + vw->Flush (); + vw->Sync (); + vw->UnlockLooper (); +} + +void +BView_scroll_bar_update (void *sb, int portion, int whole, int position) +{ + BScrollBar *bar = (BScrollBar *) sb; + BMessage msg = BMessage (SCROLL_BAR_UPDATE); + BMessenger mr = BMessenger (bar); + msg.AddInt32 ("emacs:range", whole); + msg.AddInt32 ("emacs:units", position); + + mr.SendMessage (&msg); +} + +/* Return the default scrollbar size. */ +int +BScrollBar_default_size (int horizontal_p) +{ + return horizontal_p ? B_H_SCROLL_BAR_HEIGHT : B_V_SCROLL_BAR_WIDTH; +} + +/* Invalidate VIEW, causing it to be drawn again. */ +void +BView_invalidate (void *view) +{ + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Couldn't lock view while invalidating it"); + vw->Invalidate (); + vw->UnlockLooper (); +} + +/* Lock VIEW in preparation for drawing operations. This should be + called before any attempt to draw onto VIEW or to lock it for Cairo + drawing. `BView_draw_unlock' should be called afterwards. */ +void +BView_draw_lock (void *view) +{ + EmacsView *vw = (EmacsView *) view; + if (vw->looper_locked_count) + { + vw->looper_locked_count++; + return; + } + BView *v = (BView *) find_appropriate_view_for_draw (vw); + if (v != vw) + { + if (!vw->offscreen_draw_bitmap_1->Lock ()) + gui_abort ("Failed to lock offscreen bitmap while acquiring draw lock"); + } + else if (!v->LockLooper ()) + gui_abort ("Failed to lock draw view while acquiring draw lock"); + + if (v != vw && !vw->LockLooper ()) + gui_abort ("Failed to lock view while acquiring draw lock"); + vw->looper_locked_count++; +} + +void +BView_draw_unlock (void *view) +{ + EmacsView *vw = (EmacsView *) view; + if (--vw->looper_locked_count) + return; + + BView *v = (BView *) find_appropriate_view_for_draw (view); + if (v == vw) + vw->UnlockLooper (); + else + { + vw->offscreen_draw_bitmap_1->Unlock (); + vw->UnlockLooper (); + } +} + +void +BWindow_center_on_screen (void *window) +{ + BWindow *w = (BWindow *) window; + w->CenterOnScreen (); +} + +/* Tell VIEW it has been clicked at X by Y. */ +void +BView_mouse_down (void *view, int x, int y) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->MouseDown (BPoint (x, y)); + vw->UnlockLooper (); + } +} + +/* Tell VIEW the mouse has been released at X by Y. */ +void +BView_mouse_up (void *view, int x, int y) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->MouseUp (BPoint (x, y)); + vw->UnlockLooper (); + } +} + +/* Tell VIEW that the mouse has moved to Y by Y. */ +void +BView_mouse_moved (void *view, int x, int y, uint32_t transit) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->MouseMoved (BPoint (x, y), transit, NULL); + vw->UnlockLooper (); + } +} + +/* Import BITS into BITMAP using the B_GRAY1 colorspace. */ +void +BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h) +{ + BBitmap *bmp = (BBitmap *) bitmap; + unsigned char *data = (unsigned char *) bmp->Bits (); + unsigned short *bts = (unsigned short *) bits; + + for (int i = 0; i < (h * (wd / 8)); i++) + { + *((unsigned short *) data) = bts[i]; + data += bmp->BytesPerRow (); + } +} + +/* Make a scrollbar at X, Y known to the view VIEW. */ +void +BView_publish_scroll_bar (void *view, int x, int y, int width, int height) +{ + EmacsView *vw = (EmacsView *) view; + if (vw->LockLooper ()) + { + vw->sb_region.Include (BRect (x, y, x - 1 + width, + y - 1 + height)); + vw->UnlockLooper (); + } +} + +void +BView_forget_scroll_bar (void *view, int x, int y, int width, int height) +{ + EmacsView *vw = (EmacsView *) view; + if (vw->LockLooper ()) + { + vw->sb_region.Exclude (BRect (x, y, x - 1 + width, + y - 1 + height)); + vw->UnlockLooper (); + } +} + +void +BView_get_mouse (void *view, int *x, int *y) +{ + BPoint l; + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view in BView_get_mouse"); + vw->GetMouse (&l, NULL, 1); + vw->UnlockLooper (); + + *x = std::lrint (l.x); + *y = std::lrint (l.y); +} + +/* Perform an in-place conversion of X and Y from VIEW's coordinate + system to its screen's coordinate system. */ +void +BView_convert_to_screen (void *view, int *x, int *y) +{ + BPoint l = BPoint (*x, *y); + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view in convert_to_screen"); + vw->ConvertToScreen (&l); + vw->UnlockLooper (); + + *x = std::lrint (l.x); + *y = std::lrint (l.y); +} + +void +BView_convert_from_screen (void *view, int *x, int *y) +{ + BPoint l = BPoint (*x, *y); + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view in convert_from_screen"); + vw->ConvertFromScreen (&l); + vw->UnlockLooper (); + + *x = std::lrint (l.x); + *y = std::lrint (l.y); +} + +/* Decorate or undecorate WINDOW depending on DECORATE_P. */ +void +BWindow_change_decoration (void *window, int decorate_p) +{ + BWindow *w = (BWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while changing its decorations"); + if (decorate_p) + w->SetLook (B_TITLED_WINDOW_LOOK); + else + w->SetLook (B_NO_BORDER_WINDOW_LOOK); + w->UnlockLooper (); +} + +/* Decorate WINDOW appropriately for use as a tooltip. */ +void +BWindow_set_tooltip_decoration (void *window) +{ + BWindow *w = (BWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while setting ttip decoration"); + w->SetLook (B_BORDERED_WINDOW_LOOK); + w->SetFeel (B_FLOATING_APP_WINDOW_FEEL); + w->UnlockLooper (); +} + +/* Set B_AVOID_FOCUS on WINDOW if AVOID_FOCUS_P is non-nil, or clear + it otherwise. */ +void +BWindow_set_avoid_focus (void *window, int avoid_focus_p) +{ + BWindow *w = (BWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while setting avoid focus"); + + if (!avoid_focus_p) + w->SetFlags (w->Flags () & ~B_AVOID_FOCUS); + else + w->SetFlags (w->Flags () | B_AVOID_FOCUS); + w->Sync (); + w->UnlockLooper (); +} + +void +BView_emacs_delete (void *view) +{ + EmacsView *vw = (EmacsView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view while deleting it"); + vw->RemoveSelf (); + delete vw; +} + +/* Return the current workspace. */ +uint32_t +haiku_current_workspace (void) +{ + return current_workspace (); +} + +/* Return a bitmask consisting of workspaces WINDOW is on. */ +uint32_t +BWindow_workspaces (void *window) +{ + return ((BWindow *) window)->Workspaces (); +} + +/* Create a popup menu. */ +void * +BPopUpMenu_new (const char *name) +{ + BPopUpMenu *menu = new EmacsPopUpMenu (name); + menu->SetRadioMode (0); + return menu; +} + +/* Add a title item to MENU. These items cannot be highlighted or + triggered, and their labels will display as bold text. */ +void +BMenu_add_title (void *menu, const char *text) +{ + EmacsTitleMenuItem *it = new EmacsTitleMenuItem (text); + BMenu *mn = (BMenu *) menu; + mn->AddItem (it); +} + +/* Add an item to the menu MENU. */ +void +BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p, + bool marked_p, bool mbar_p, void *mbw_ptr, const char *key, + const char *help) +{ + BMenu *m = (BMenu *) menu; + BMessage *msg; + if (ptr) + msg = new BMessage (); + EmacsMenuItem *it = new EmacsMenuItem (key, label, help, ptr ? msg : NULL); + it->SetTarget (m->Window ()); + it->SetEnabled (enabled_p); + it->SetMarked (marked_p); + if (mbar_p) + { + it->menu_bar_id = (intptr_t) ptr; + it->wind_ptr = mbw_ptr; + } + if (ptr) + msg->AddPointer ("menuptr", ptr); + m->AddItem (it); +} + +/* Add a separator to the menu MENU. */ +void +BMenu_add_separator (void *menu) +{ + BMenu *m = (BMenu *) menu; + + m->AddSeparatorItem (); +} + +/* Create a submenu and attach it to MENU. */ +void * +BMenu_new_submenu (void *menu, const char *label, bool enabled_p) +{ + BMenu *m = (BMenu *) menu; + BMenu *mn = new BMenu (label, B_ITEMS_IN_COLUMN); + mn->SetRadioMode (0); + BMenuItem *i = new BMenuItem (mn); + i->SetEnabled (enabled_p); + m->AddItem (i); + return mn; +} + +/* Create a submenu that notifies Emacs upon opening. */ +void * +BMenu_new_menu_bar_submenu (void *menu, const char *label) +{ + BMenu *m = (BMenu *) menu; + BMenu *mn = new BMenu (label, B_ITEMS_IN_COLUMN); + mn->SetRadioMode (0); + BMenuItem *i = new BMenuItem (mn); + i->SetEnabled (1); + m->AddItem (i); + return mn; +} + +/* Run MENU, waiting for it to close, and return a pointer to the + data of the selected item (if one exists), or NULL. X, Y should + be in the screen coordinate system. */ +void * +BMenu_run (void *menu, int x, int y) +{ + BPopUpMenu *mn = (BPopUpMenu *) menu; + mn->SetRadioMode (0); + BMenuItem *it = mn->Go (BPoint (x, y)); + if (it) + { + BMessage *mg = it->Message (); + if (mg) + return (void *) mg->GetPointer ("menuptr"); + else + return NULL; + } + return NULL; +} + +/* Delete the entire menu hierarchy of MENU, and then delete MENU + itself. */ +void +BPopUpMenu_delete (void *menu) +{ + delete (BPopUpMenu *) menu; +} + +/* Create a menubar, attach it to VIEW, and return it. */ +void * +BMenuBar_new (void *view) +{ + BView *vw = (BView *) view; + EmacsMenuBar *bar = new EmacsMenuBar (); + + if (!vw->LockLooper ()) + gui_abort ("Failed to lock menu bar parent"); + vw->AddChild ((BView *) bar); + vw->UnlockLooper (); + + return bar; +} + +/* Delete MENUBAR along with all subitems. */ +void +BMenuBar_delete (void *menubar) +{ + BView *vw = (BView *) menubar; + BView *p = vw->Parent (); + if (!p->LockLooper ()) + gui_abort ("Failed to lock menu bar parent while removing menubar"); + vw->RemoveSelf (); + p->UnlockLooper (); + delete vw; +} + +/* Delete all items from MENU. */ +void +BMenu_delete_all (void *menu) +{ + BMenu *mn = (BMenu *) menu; + mn->RemoveItems (0, mn->CountItems (), true); +} + +/* Delete COUNT items from MENU starting from START. */ +void +BMenu_delete_from (void *menu, int start, int count) +{ + BMenu *mn = (BMenu *) menu; + mn->RemoveItems (start, count, true); +} + +/* Count items in menu MENU. */ +int +BMenu_count_items (void *menu) +{ + return ((BMenu *) menu)->CountItems (); +} + +/* Find the item in MENU at IDX. */ +void * +BMenu_item_at (void *menu, int idx) +{ + return ((BMenu *) menu)->ItemAt (idx); +} + +/* Set ITEM's label to LABEL. */ +void +BMenu_item_set_label (void *item, const char *label) +{ + ((BMenuItem *) item)->SetLabel (label); +} + +/* Get ITEM's menu. */ +void * +BMenu_item_get_menu (void *item) +{ + return ((BMenuItem *) item)->Submenu (); +} + +/* Emit a beep noise. */ +void +haiku_ring_bell (void) +{ + beep (); +} + +/* Create a BAlert with TEXT. */ +void * +BAlert_new (const char *text, enum haiku_alert_type type) +{ + return new BAlert (NULL, text, NULL, NULL, NULL, B_WIDTH_AS_USUAL, + (enum alert_type) type); +} + +/* Add a button to ALERT and return the button. */ +void * +BAlert_add_button (void *alert, const char *text) +{ + BAlert *al = (BAlert *) alert; + al->AddButton (text); + return al->ButtonAt (al->CountButtons () - 1); +} + +/* Run ALERT, returning the number of the button that was selected, + or -1 if no button was selected before the alert was closed. */ +int32_t +BAlert_go (void *alert) +{ + return ((BAlert *) alert)->Go (); +} + +/* Enable or disable BUTTON depending on ENABLED_P. */ +void +BButton_set_enabled (void *button, int enabled_p) +{ + ((BButton *) button)->SetEnabled (enabled_p); +} + +/* Set VIEW's tooltip to TOOLTIP. */ +void +BView_set_tooltip (void *view, const char *tooltip) +{ + ((BView *) view)->SetToolTip (tooltip); +} + +/* Set VIEW's tooltip to a sticky tooltip at X by Y. */ +void +BView_set_and_show_sticky_tooltip (void *view, const char *tooltip, + int x, int y) +{ + BToolTip *tip; + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view while showing sticky tooltip"); + vw->SetToolTip (tooltip); + tip = vw->ToolTip (); + BPoint pt; + EmacsView *ev = dynamic_cast (vw); + if (ev) + ev->tt_absl_pos = BPoint (x, y); + + vw->GetMouse (&pt, NULL, 1); + pt.x -= x; + pt.y -= y; + + pt.x = -pt.x; + pt.y = -pt.y; + + tip->SetMouseRelativeLocation (pt); + tip->SetSticky (1); + vw->ShowToolTip (tip); + vw->UnlockLooper (); +} + +/* Delete ALERT. */ +void +BAlert_delete (void *alert) +{ + delete (BAlert *) alert; +} + +/* Place the resolution of the monitor in DPI in RSSX and RSSY. */ +void +BScreen_res (double *rrsx, double *rrsy) +{ + BScreen s (B_MAIN_SCREEN_ID); + if (!s.IsValid ()) + gui_abort ("Invalid screen for resolution checks"); + monitor_info i; + + if (s.GetMonitorInfo (&i) == B_OK) + { + *rrsx = (double) i.width / (double) 2.54; + *rrsy = (double) i.height / (double) 2.54; + } + else + { + *rrsx = 72.27; + *rrsy = 72.27; + } +} + +/* Add WINDOW to OTHER_WINDOW's subset and parent it to + OTHER_WINDOW. */ +void +EmacsWindow_parent_to (void *window, void *other_window) +{ + EmacsWindow *w = (EmacsWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while parenting"); + w->ParentTo ((EmacsWindow *) other_window); + w->UnlockLooper (); +} + +void +EmacsWindow_unparent (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while unparenting"); + w->UnparentAndUnlink (); + w->UnlockLooper (); +} + +/* Place text describing the current version of Haiku in VERSION, + which should be a buffer LEN bytes wide. */ +void +be_get_version_string (char *version, int len) +{ + std::strncpy (version, "Unknown Haiku release", len - 1); + BPath path; + if (find_directory (B_BEOS_LIB_DIRECTORY, &path) == B_OK) + { + path.Append ("libbe.so"); + + BAppFileInfo appFileInfo; + version_info versionInfo; + BFile file; + if (file.SetTo (path.Path (), B_READ_ONLY) == B_OK + && appFileInfo.SetTo (&file) == B_OK + && appFileInfo.GetVersionInfo (&versionInfo, + B_APP_VERSION_KIND) == B_OK + && versionInfo.short_info[0] != '\0') + std::strncpy (version, versionInfo.short_info, len - 1); + } +} + +/* Return the amount of color planes in the current display. */ +int +be_get_display_planes (void) +{ + color_space space = dpy_color_space; + if (space == B_NO_COLOR_SPACE) + { + BScreen screen; /* This is actually a very slow operation. */ + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + space = dpy_color_space = screen.ColorSpace (); + } + + if (space == B_RGB32 || space == B_RGB24) + return 24; + if (space == B_RGB16) + return 16; + if (space == B_RGB15) + return 15; + if (space == B_CMAP8) + return 8; + + gui_abort ("Bad colorspace for screen"); + /* https://www.haiku-os.org/docs/api/classBScreen.html + says a valid screen can't be anything else. */ + return -1; +} + +/* Return the amount of colors the display can handle. */ +int +be_get_display_color_cells (void) +{ + color_space space = dpy_color_space; + if (space == B_NO_COLOR_SPACE) + { + BScreen screen; + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + space = dpy_color_space = screen.ColorSpace (); + } + + if (space == B_RGB32 || space == B_RGB24) + return 1677216; + if (space == B_RGB16) + return 65536; + if (space == B_RGB15) + return 32768; + if (space == B_CMAP8) + return 256; + + gui_abort ("Bad colorspace for screen"); + return -1; +} + +/* Warp the pointer to X by Y. */ +void +be_warp_pointer (int x, int y) +{ + /* We're not supposed to use the following function without a + BWindowScreen object, but in Haiku nothing actually prevents us + from doing so. */ + + set_mouse_position (x, y); +} + +/* Update the position of CHILD in WINDOW without actually moving + it. */ +void +EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff) +{ + EmacsWindow *w = (EmacsWindow *) window; + EmacsWindow *c = (EmacsWindow *) child; + + if (!w->LockLooper ()) + gui_abort ("Couldn't lock window for weak move"); + w->MoveChild (c, xoff, yoff, 1); + w->UnlockLooper (); +} + +/* Find an appropriate view to draw onto. If VW is double-buffered, + this will be the view used for double buffering instead of VW + itself. */ +void * +find_appropriate_view_for_draw (void *vw) +{ + BView *v = (BView *) vw; + EmacsView *ev = dynamic_cast(v); + if (!ev) + return v; + + return ev->offscreen_draw_view ? ev->offscreen_draw_view : vw; +} + +/* Set up double buffering for VW. */ +void +EmacsView_set_up_double_buffering (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view while setting up double buffering"); + if (view->offscreen_draw_view) + { + view->UnlockLooper (); + return; + } + view->SetUpDoubleBuffering (); + view->UnlockLooper (); +} + +/* Flip and invalidate the view VW. */ +void +EmacsView_flip_and_blit (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->offscreen_draw_view) + return; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view in flip_and_blit"); + view->FlipBuffers (); + view->UnlockLooper (); +} + +/* Disable double buffering for VW. */ +void +EmacsView_disable_double_buffering (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view tearing down double buffering"); + view->TearDownDoubleBuffering (); + view->UnlockLooper (); +} + +/* Return non-0 if VW is double-buffered. */ +int +EmacsView_double_buffered_p (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view testing double buffering status"); + int db_p = !!view->offscreen_draw_view; + view->UnlockLooper (); + return db_p; +} + +struct popup_file_dialog_data +{ + BMessage *msg; + BFilePanel *panel; + BEntry *entry; +}; + +static void +unwind_popup_file_dialog (void *ptr) +{ + struct popup_file_dialog_data *data = + (struct popup_file_dialog_data *) ptr; + BFilePanel *panel = data->panel; + delete panel; + delete data->entry; + delete data->msg; +} + +static void +be_popup_file_dialog_safe_set_target (BFilePanel *dialog, BWindow *window) +{ + dialog->SetTarget (BMessenger (window)); +} + +/* Popup a file dialog. */ +char * +be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, int dir_only_p, + void *window, const char *save_text, const char *prompt, + void (*block_input_function) (void), + void (*unblock_input_function) (void)) +{ + ptrdiff_t idx = c_specpdl_idx_from_cxx (); + /* setjmp/longjmp is UB with automatic objects. */ + block_input_function (); + BWindow *w = (BWindow *) window; + uint32_t mode = dir_only_p ? B_DIRECTORY_NODE : B_FILE_NODE | B_DIRECTORY_NODE; + BEntry *path = new BEntry; + BMessage *msg = new BMessage ('FPSE'); + BFilePanel *panel = new BFilePanel (open_p ? B_OPEN_PANEL : B_SAVE_PANEL, + NULL, NULL, mode); + unblock_input_function (); + + struct popup_file_dialog_data dat; + dat.entry = path; + dat.msg = msg; + dat.panel = panel; + + record_c_unwind_protect_from_cxx (unwind_popup_file_dialog, &dat); + if (default_dir) + { + if (path->SetTo (default_dir, 0) != B_OK) + default_dir = NULL; + } + + panel->SetMessage (msg); + if (default_dir) + panel->SetPanelDirectory (path); + if (save_text) + panel->SetSaveText (save_text); + panel->SetHideWhenDone (0); + panel->Window ()->SetTitle (prompt); + be_popup_file_dialog_safe_set_target (panel, w); + + panel->Show (); + panel->Window ()->Show (); + + void *buf = alloca (200); + while (1) + { + enum haiku_event_type type; + char *ptr = NULL; + + if (!haiku_read_with_timeout (&type, buf, 200, 100000)) + { + if (type != FILE_PANEL_EVENT) + haiku_write (type, buf); + else if (!ptr) + ptr = (char *) ((struct haiku_file_panel_event *) buf)->ptr; + } + + ssize_t b_s; + haiku_read_size (&b_s); + if (!b_s || b_s == -1 || ptr || panel->Window ()->IsHidden ()) + { + c_unbind_to_nil_from_cxx (idx); + return ptr; + } + } +} + +void +be_app_quit (void) +{ + if (be_app) + { + status_t e; + while (!be_app->Lock ()); + be_app->Quit (); + wait_for_thread (app_thread, &e); + } +} + +/* Temporarily fill VIEW with COLOR. */ +void +EmacsView_do_visible_bell (void *view, uint32_t color) +{ + EmacsView *vw = (EmacsView *) view; + vw->DoVisibleBell (color); +} + +/* Zoom WINDOW. */ +void +BWindow_zoom (void *window) +{ + BWindow *w = (BWindow *) window; + w->Zoom (); +} + +/* Make WINDOW fullscreen if FULLSCREEN_P. */ +void +EmacsWindow_make_fullscreen (void *window, int fullscreen_p) +{ + EmacsWindow *w = (EmacsWindow *) window; + w->MakeFullscreen (fullscreen_p); +} + +/* Unzoom (maximize) WINDOW. */ +void +EmacsWindow_unzoom (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + w->UnZoom (); +} + +/* Move the pointer into MBAR and start tracking. */ +void +BMenuBar_start_tracking (void *mbar) +{ + EmacsMenuBar *mb = (EmacsMenuBar *) mbar; + if (!mb->LockLooper ()) + gui_abort ("Couldn't lock menubar"); + BRect frame = mb->Frame (); + BPoint pt = frame.LeftTop (); + BPoint l = pt; + mb->Parent ()->ConvertToScreen (&pt); + set_mouse_position (pt.x, pt.y); + mb->MouseDown (l); + mb->UnlockLooper (); +} + +#ifdef HAVE_NATIVE_IMAGE_API +int +be_can_translate_type_to_bitmap_p (const char *mime) +{ + BTranslatorRoster *r = BTranslatorRoster::Default (); + translator_id *ids; + int32 id_len; + + if (r->GetAllTranslators (&ids, &id_len) != B_OK) + return 0; + + int found_in = 0; + int found_out = 0; + + for (int i = 0; i < id_len; ++i) + { + found_in = 0; + found_out = 0; + const translation_format *i_fmts; + const translation_format *o_fmts; + + int32 i_count, o_count; + + if (r->GetInputFormats (ids[i], &i_fmts, &i_count) != B_OK) + continue; + + if (r->GetOutputFormats (ids[i], &o_fmts, &o_count) != B_OK) + continue; + + for (int x = 0; x < i_count; ++x) + { + if (!strcmp (i_fmts[x].MIME, mime)) + { + found_in = 1; + break; + } + } + + for (int x = 0; x < i_count; ++x) + { + if (!strcmp (o_fmts[x].MIME, "image/x-be-bitmap") || + !strcmp (o_fmts[x].MIME, "image/x-vnd.Be-bitmap")) + { + found_out = 1; + break; + } + } + + if (found_in && found_out) + break; + } + + delete [] ids; + + return found_in && found_out; +} + +void * +be_translate_bitmap_from_file_name (const char *filename) +{ + BBitmap *bm = BTranslationUtils::GetBitmap (filename); + return bm; +} + +void * +be_translate_bitmap_from_memory (const void *buf, size_t bytes) +{ + BMemoryIO io (buf, bytes); + BBitmap *bm = BTranslationUtils::GetBitmap (&io); + return bm; +} +#endif + +/* Return the size of BITMAP's data, in bytes. */ +size_t +BBitmap_bytes_length (void *bitmap) +{ + BBitmap *bm = (BBitmap *) bitmap; + return bm->BitsLength (); +} + +/* Show VIEW's tooltip. */ +void +BView_show_tooltip (void *view) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->ShowToolTip (vw->ToolTip ()); + vw->UnlockLooper (); + } +} + + +#ifdef USE_BE_CAIRO +/* Return VIEW's cairo surface. */ +cairo_surface_t * +EmacsView_cairo_surface (void *view) +{ + EmacsView *vw = (EmacsView *) view; + EmacsWindow *wn = (EmacsWindow *) vw->Window (); + return vw->cr_surface ? vw->cr_surface : wn->cr_surface; +} + +/* Transfer each clip rectangle in VIEW to the cairo context + CTX. */ +void +BView_cr_dump_clipping (void *view, cairo_t *ctx) +{ + BView *vw = (BView *) find_appropriate_view_for_draw (view); + BRegion cr; + vw->GetClippingRegion (&cr); + + for (int i = 0; i < cr.CountRects (); ++i) + { + BRect r = cr.RectAt (i); + cairo_rectangle (ctx, r.left, r.top, r.Width () + 1, + r.Height () + 1); + } + + cairo_clip (ctx); +} + +/* Lock WINDOW in preparation for drawing using Cairo. */ +void +EmacsWindow_begin_cr_critical_section (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + if (!w->surface_lock.Lock ()) + gui_abort ("Couldn't lock cairo surface"); + + BView *vw = (BView *) w->FindView ("Emacs"); + EmacsView *ev = dynamic_cast (vw); + if (ev && !ev->cr_surface_lock.Lock ()) + gui_abort ("Couldn't lock view cairo surface"); +} + +/* Unlock WINDOW in preparation for drawing using Cairo. */ +void +EmacsWindow_end_cr_critical_section (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + w->surface_lock.Unlock (); + BView *vw = (BView *) w->FindView ("Emacs"); + EmacsView *ev = dynamic_cast (vw); + if (ev) + ev->cr_surface_lock.Unlock (); +} +#endif + +/* Get the width of STR in the plain font. */ +int +be_string_width_with_plain_font (const char *str) +{ + return be_plain_font->StringWidth (str); +} + +/* Get the ascent + descent of the plain font. */ +int +be_plain_font_height (void) +{ + struct font_height fheight; + be_plain_font->GetHeight (&fheight); + + return fheight.ascent + fheight.descent; +} + +/* Return the number of physical displays connected. */ +int +be_get_display_screens (void) +{ + int count = 1; + BScreen scr; + + if (!scr.IsValid ()) + gui_abort ("Main screen vanished!"); + while (scr.SetToNext () == B_OK && scr.IsValid ()) + ++count; + + return count; +} + +/* Set the minimum width the user can resize WINDOW to. */ +void +BWindow_set_min_size (void *window, int width, int height) +{ + BWindow *w = (BWindow *) window; + + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper setting min size"); + w->SetSizeLimits (width, -1, height, -1); + w->UnlockLooper (); +} + +/* Set the alignment of WINDOW's dimensions. */ +void +BWindow_set_size_alignment (void *window, int align_width, int align_height) +{ + BWindow *w = (BWindow *) window; + + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper setting alignment"); +#if 0 /* Haiku does not currently implement SetWindowAlignment. */ + if (w->SetWindowAlignment (B_PIXEL_ALIGNMENT, -1, -1, align_width, + align_width, -1, -1, align_height, + align_height) != B_NO_ERROR) + gui_abort ("Invalid pixel alignment"); +#endif + w->UnlockLooper (); +} diff --git a/src/haiku_support.h b/src/haiku_support.h new file mode 100644 index 00000000000..9f5f3c77e3d --- /dev/null +++ b/src/haiku_support.h @@ -0,0 +1,869 @@ +/* Haiku window system support. Hey Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_SUPPORT_H +#define _HAIKU_SUPPORT_H + +#include + +#ifdef HAVE_FREETYPE +#include +#include +#include FT_FREETYPE_H +#include FT_SIZES_H +#endif + +#ifdef USE_BE_CAIRO +#include +#endif + +enum haiku_cursor + { + CURSOR_ID_NO_CURSOR = 12, + CURSOR_ID_RESIZE_NORTH = 15, + CURSOR_ID_RESIZE_EAST = 16, + CURSOR_ID_RESIZE_SOUTH = 17, + CURSOR_ID_RESIZE_WEST = 18, + CURSOR_ID_RESIZE_NORTH_EAST = 19, + CURSOR_ID_RESIZE_NORTH_WEST = 20, + CURSOR_ID_RESIZE_SOUTH_EAST = 21, + CURSOR_ID_RESIZE_SOUTH_WEST = 22, + CURSOR_ID_RESIZE_NORTH_SOUTH = 23, + CURSOR_ID_RESIZE_EAST_WEST = 24, + CURSOR_ID_RESIZE_NORTH_EAST_SOUTH_WEST = 25, + CURSOR_ID_RESIZE_NORTH_WEST_SOUTH_EAST = 26 + }; + +enum haiku_alert_type + { + HAIKU_EMPTY_ALERT = 0, + HAIKU_INFO_ALERT, + HAIKU_IDEA_ALERT, + HAIKU_WARNING_ALERT, + HAIKU_STOP_ALERT + }; + +enum haiku_event_type + { + QUIT_REQUESTED, + FRAME_RESIZED, + FRAME_EXPOSED, + KEY_DOWN, + KEY_UP, + ACTIVATION, + MOUSE_MOTION, + BUTTON_DOWN, + BUTTON_UP, + ICONIFICATION, + MOVE_EVENT, + SCROLL_BAR_VALUE_EVENT, + SCROLL_BAR_DRAG_EVENT, + WHEEL_MOVE_EVENT, + MENU_BAR_RESIZE, + MENU_BAR_OPEN, + MENU_BAR_SELECT_EVENT, + MENU_BAR_CLOSE, + FILE_PANEL_EVENT, + MENU_BAR_HELP_EVENT, + ZOOM_EVENT, + REFS_EVENT, + APP_QUIT_REQUESTED_EVENT + }; + +struct haiku_quit_requested_event +{ + void *window; +}; + +struct haiku_resize_event +{ + void *window; + float px_heightf; + float px_widthf; +}; + +struct haiku_expose_event +{ + void *window; + int x; + int y; + int width; + int height; +}; + +struct haiku_refs_event +{ + void *window; + int x, y; + /* Free this with free! */ + char *ref; +}; + +struct haiku_app_quit_requested_event +{ + char dummy; +}; + +#define HAIKU_MODIFIER_ALT (1) +#define HAIKU_MODIFIER_CTRL (1 << 1) +#define HAIKU_MODIFIER_SHIFT (1 << 2) +#define HAIKU_MODIFIER_SUPER (1 << 3) + +struct haiku_key_event +{ + void *window; + int modifiers; + uint32_t mb_char; + uint32_t unraw_mb_char; + short kc; +}; + +struct haiku_activation_event +{ + void *window; + int activated_p; +}; + +struct haiku_mouse_motion_event +{ + void *window; + bool just_exited_p; + int x; + int y; + uint32_t be_code; +}; + +struct haiku_button_event +{ + void *window; + int btn_no; + int modifiers; + int x; + int y; +}; + +struct haiku_iconification_event +{ + void *window; + int iconified_p; +}; + +struct haiku_move_event +{ + void *window; + int x; + int y; +}; + +struct haiku_wheel_move_event +{ + void *window; + int modifiers; + float delta_x; + float delta_y; +}; + +struct haiku_menu_bar_select_event +{ + void *window; + void *ptr; +}; + +struct haiku_file_panel_event +{ + void *ptr; +}; + +struct haiku_menu_bar_help_event +{ + void *window; + int mb_idx; +}; + +struct haiku_zoom_event +{ + void *window; + int x; + int y; + int width; + int height; +}; + +#define FSPEC_FAMILY 1 +#define FSPEC_STYLE (1 << 1) +#define FSPEC_SLANT (1 << 2) +#define FSPEC_WEIGHT (1 << 3) +#define FSPEC_SPACING (1 << 4) +#define FSPEC_WANTED (1 << 5) +#define FSPEC_NEED_ONE_OF (1 << 6) +#define FSPEC_WIDTH (1 << 7) +#define FSPEC_LANGUAGE (1 << 8) + +typedef char haiku_font_family_or_style[64]; + +enum haiku_font_slant + { + NO_SLANT = -1, + SLANT_OBLIQUE, + SLANT_REGULAR, + SLANT_ITALIC + }; + +enum haiku_font_width + { + NO_WIDTH = -1, + ULTRA_CONDENSED, + EXTRA_CONDENSED, + CONDENSED, + SEMI_CONDENSED, + NORMAL_WIDTH, + SEMI_EXPANDED, + EXPANDED, + EXTRA_EXPANDED, + ULTRA_EXPANDED + }; + +enum haiku_font_language + { + LANGUAGE_CN, + LANGUAGE_KO, + LANGUAGE_JP, + MAX_LANGUAGE /* This isn't a language. */ + }; + +struct haiku_font_pattern +{ + int specified; + struct haiku_font_pattern *next; + /* The next two fields are only temporarily used during the font + discovery process! Do not rely on them being correct outside + BFont_find. */ + struct haiku_font_pattern *last; + struct haiku_font_pattern *next_family; + haiku_font_family_or_style family; + haiku_font_family_or_style style; + int weight; + int mono_spacing_p; + int want_chars_len; + int need_one_of_len; + enum haiku_font_slant slant; + enum haiku_font_width width; + enum haiku_font_language language; + uint32_t *wanted_chars; + uint32_t *need_one_of; + + int oblique_seen_p; +}; + +struct haiku_scroll_bar_value_event +{ + void *scroll_bar; + int position; +}; + +struct haiku_scroll_bar_drag_event +{ + void *scroll_bar; + int dragging_p; +}; + +struct haiku_menu_bar_resize_event +{ + void *window; + int width; + int height; +}; + +struct haiku_menu_bar_state_event +{ + void *window; +}; + +#define HAIKU_THIN 0 +#define HAIKU_ULTRALIGHT 20 +#define HAIKU_EXTRALIGHT 40 +#define HAIKU_LIGHT 50 +#define HAIKU_SEMI_LIGHT 75 +#define HAIKU_REGULAR 100 +#define HAIKU_SEMI_BOLD 180 +#define HAIKU_BOLD 200 +#define HAIKU_EXTRA_BOLD 205 +#define HAIKU_ULTRA_BOLD 210 +#define HAIKU_BOOK 400 +#define HAIKU_HEAVY 800 +#define HAIKU_ULTRA_HEAVY 900 +#define HAIKU_BLACK 1000 +#define HAIKU_MEDIUM 2000 + +#ifdef __cplusplus +extern "C" +{ +#endif +#include +#include + +#ifdef __cplusplus + typedef void *haiku; + + extern void + haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel); + + extern unsigned long + haiku_get_pixel (haiku bitmap, int x, int y); +#endif + + extern port_id port_application_to_emacs; + + extern void haiku_io_init (void); + extern void haiku_io_init_in_app_thread (void); + + extern void + haiku_read_size (ssize_t *len); + + extern int + haiku_read (enum haiku_event_type *type, void *buf, ssize_t len); + + extern int + haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len, + time_t timeout); + + extern int + haiku_write (enum haiku_event_type type, void *buf); + + extern int + haiku_write_without_signal (enum haiku_event_type type, void *buf); + + extern void + rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l); + + extern void + hsl_color_rgb (double h, double s, double l, uint32_t *rgb); + + extern void * + BBitmap_new (int width, int height, int mono_p); + + extern void * + BBitmap_data (void *bitmap); + + extern int + BBitmap_convert (void *bitmap, void **new_bitmap); + + extern void + BBitmap_free (void *bitmap); + + extern void + BBitmap_dimensions (void *bitmap, int *left, int *top, + int *right, int *bottom, int32_t *bytes_per_row, + int *mono_p); + + extern void * + BApplication_setup (void); + + extern void * + BWindow_new (void *view); + + extern void + BWindow_quit (void *window); + + extern void + BWindow_set_offset (void *window, int x, int y); + + extern void + BWindow_iconify (void *window); + + extern void + BWindow_set_visible (void *window, int visible_p); + + extern void + BFont_close (void *font); + + extern void + BFont_dat (void *font, int *px_size, int *min_width, int *max_width, + int *avg_width, int *height, int *space_width, int *ascent, + int *descent, int *underline_position, int *underline_thickness); + + extern int + BFont_have_char_p (void *font, int32_t chr); + + extern int + BFont_have_char_block (void *font, int32_t beg, int32_t end); + + extern void + BFont_char_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb); + + extern void + BFont_nchar_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb, int32_t n); + + extern void + BWindow_retitle (void *window, const char *title); + + extern void + BWindow_resize (void *window, int width, int height); + + extern void + BWindow_activate (void *window); + + extern void + BView_StartClip (void *view); + + extern void + BView_EndClip (void *view); + + extern void + BView_SetHighColor (void *view, uint32_t color); + + extern void + BView_SetHighColorForVisibleBell (void *view, uint32_t color); + + extern void + BView_FillRectangleForVisibleBell (void *view, int x, int y, int width, + int height); + + extern void + BView_SetLowColor (void *view, uint32_t color); + + extern void + BView_SetPenSize (void *view, int u); + + extern void + BView_SetFont (void *view, void *font); + + extern void + BView_MovePenTo (void *view, int x, int y); + + extern void + BView_DrawString (void *view, const char *chr, ptrdiff_t len); + + extern void + BView_DrawChar (void *view, char chr); + + extern void + BView_FillRectangle (void *view, int x, int y, int width, int height); + + extern void + BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1); + + extern void + BView_FillTriangle (void *view, int x1, int y1, + int x2, int y2, int x3, int y3); + + extern void + BView_StrokeRectangle (void *view, int x, int y, int width, int height); + + extern void + BView_SetViewColor (void *view, uint32_t color); + + extern void + BView_ClipToRect (void *view, int x, int y, int width, int height); + + extern void + BView_ClipToInverseRect (void *view, int x, int y, int width, int height); + + extern void + BView_StrokeLine (void *view, int sx, int sy, int tx, int ty); + + extern void + BView_CopyBits (void *view, int x, int y, int width, int height, + int tox, int toy, int towidth, int toheight); + + extern void + BView_DrawBitmap (void *view, void *bitmap, int x, int y, + int width, int height, int vx, int vy, int vwidth, + int vheight); + + extern void + BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x, + int y, int width, int height); + + extern void + BView_DrawMask (void *src, void *view, + int x, int y, int width, int height, + int vx, int vy, int vwidth, int vheight, + uint32_t color); + + extern void * + BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color, + double rot, int desw, int desh); + + extern void + BScreen_px_dim (int *width, int *height); + + extern void + BView_resize_to (void *view, int width, int height); + + /* Functions for creating and freeing cursors. */ + extern void * + BCursor_create_default (void); + + extern void * + BCursor_from_id (enum haiku_cursor cursor); + + extern void * + BCursor_create_modeline (void); + + extern void * + BCursor_create_i_beam (void); + + extern void * + BCursor_create_progress_cursor (void); + + extern void * + BCursor_create_grab (void); + + extern void + BCursor_delete (void *cursor); + + extern void + BView_set_view_cursor (void *view, void *cursor); + + extern void + BWindow_Flush (void *window); + + extern void + BMapKey (uint32_t kc, int *non_ascii_p, unsigned *code); + + extern void * + BScrollBar_make_for_view (void *view, int horizontal_p, + int x, int y, int x1, int y1, + void *scroll_bar_ptr); + + extern void + BScrollBar_delete (void *sb); + + extern void + BView_move_frame (void *view, int x, int y, int x1, int y1); + + extern void + BView_scroll_bar_update (void *sb, int portion, int whole, int position); + + extern int + BScrollBar_default_size (int horizontal_p); + + extern void + BView_invalidate (void *view); + + extern void + BView_draw_lock (void *view); + + extern void + BView_draw_unlock (void *view); + + extern void + BWindow_center_on_screen (void *window); + + extern void + BView_mouse_moved (void *view, int x, int y, uint32_t transit); + + extern void + BView_mouse_down (void *view, int x, int y); + + extern void + BView_mouse_up (void *view, int x, int y); + + extern void + BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h); + + extern void + haiku_font_pattern_free (struct haiku_font_pattern *pt); + + extern struct haiku_font_pattern * + BFont_find (struct haiku_font_pattern *pt); + + extern int + BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size); + + extern void + BFont_populate_fixed_family (struct haiku_font_pattern *ptn); + + extern void + BFont_populate_plain_family (struct haiku_font_pattern *ptn); + + extern void + BView_publish_scroll_bar (void *view, int x, int y, int width, int height); + + extern void + BView_forget_scroll_bar (void *view, int x, int y, int width, int height); + + extern void + BView_get_mouse (void *view, int *x, int *y); + + extern void + BView_convert_to_screen (void *view, int *x, int *y); + + extern void + BView_convert_from_screen (void *view, int *x, int *y); + + extern void + BWindow_change_decoration (void *window, int decorate_p); + + extern void + BWindow_set_tooltip_decoration (void *window); + + extern void + BWindow_set_avoid_focus (void *window, int avoid_focus_p); + + extern void + BView_emacs_delete (void *view); + + extern uint32_t + haiku_current_workspace (void); + + extern uint32_t + BWindow_workspaces (void *window); + + extern void * + BPopUpMenu_new (const char *name); + + extern void + BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p, + bool marked_p, bool mbar_p, void *mbw_ptr, const char *key, + const char *help); + + extern void + BMenu_add_separator (void *menu); + + extern void * + BMenu_new_submenu (void *menu, const char *label, bool enabled_p); + + extern void * + BMenu_new_menu_bar_submenu (void *menu, const char *label); + + extern int + BMenu_count_items (void *menu); + + extern void * + BMenu_item_at (void *menu, int idx); + + extern void * + BMenu_run (void *menu, int x, int y); + + extern void + BPopUpMenu_delete (void *menu); + + extern void * + BMenuBar_new (void *view); + + extern void + BMenu_delete_all (void *menu); + + extern void + BMenuBar_delete (void *menubar); + + extern void + BMenu_item_set_label (void *item, const char *label); + + extern void * + BMenu_item_get_menu (void *item); + + extern void + BMenu_delete_from (void *menu, int start, int count); + + extern void + haiku_ring_bell (void); + + extern void * + BAlert_new (const char *text, enum haiku_alert_type type); + + extern void * + BAlert_add_button (void *alert, const char *text); + + extern int32_t + BAlert_go (void *alert); + + extern void + BButton_set_enabled (void *button, int enabled_p); + + extern void + BView_set_tooltip (void *view, const char *tooltip); + + extern void + BAlert_delete (void *alert); + + extern void + BScreen_res (double *rrsx, double *rrsy); + + extern void + EmacsWindow_parent_to (void *window, void *other_window); + + extern void + EmacsWindow_unparent (void *window); + + extern int + BFont_string_width (void *font, const char *utf8); + + extern void + be_get_version_string (char *version, int len); + + extern int + be_get_display_planes (void); + + extern int + be_get_display_color_cells (void); + + extern void + be_warp_pointer (int x, int y); + + extern void + EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff); + + extern void + EmacsView_set_up_double_buffering (void *vw); + + extern void + EmacsView_disable_double_buffering (void *vw); + + extern void + EmacsView_flip_and_blit (void *vw); + + extern int + EmacsView_double_buffered_p (void *vw); + + extern char * + be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, + int dir_only_p, void *window, const char *save_text, + const char *prompt, + void (*block_input_function) (void), + void (*unblock_input_function) (void)); + + extern void + record_c_unwind_protect_from_cxx (void (*) (void *), void *); + + extern ptrdiff_t + c_specpdl_idx_from_cxx (void); + + extern void + c_unbind_to_nil_from_cxx (ptrdiff_t idx); + + extern void + EmacsView_do_visible_bell (void *view, uint32_t color); + + extern void + BWindow_zoom (void *window); + + extern void + EmacsWindow_make_fullscreen (void *window, int fullscreen_p); + + extern void + EmacsWindow_unzoom (void *window); + +#ifdef HAVE_NATIVE_IMAGE_API + extern int + be_can_translate_type_to_bitmap_p (const char *mime); + + extern void * + be_translate_bitmap_from_file_name (const char *filename); + + extern void * + be_translate_bitmap_from_memory (const void *buf, size_t bytes); +#endif + + extern void + BMenuBar_start_tracking (void *mbar); + + extern size_t + BBitmap_bytes_length (void *bitmap); + + extern void + BView_show_tooltip (void *view); + +#ifdef USE_BE_CAIRO + extern cairo_surface_t * + EmacsView_cairo_surface (void *view); + + extern void + BView_cr_dump_clipping (void *view, cairo_t *ctx); + + extern void + EmacsWindow_begin_cr_critical_section (void *window); + + extern void + EmacsWindow_end_cr_critical_section (void *window); +#endif + + extern void + BView_set_and_show_sticky_tooltip (void *view, const char *tooltip, + int x, int y); + + extern void + BMenu_add_title (void *menu, const char *text); + + extern int + be_plain_font_height (void); + + extern int + be_string_width_with_plain_font (const char *str); + + extern int + be_get_display_screens (void); + + extern void + BWindow_set_min_size (void *window, int width, int height); + + extern void + BWindow_set_size_alignment (void *window, int align_width, int align_height); + +#ifdef __cplusplus + extern void * + find_appropriate_view_for_draw (void *vw); +} + +extern _Noreturn void +gui_abort (const char *msg); +#endif /* _cplusplus */ + +/* Borrowed from X.Org keysymdef.h */ +#define XK_BackSpace 0xff08 /* Back space, back char */ +#define XK_Tab 0xff09 +#define XK_Linefeed 0xff0a /* Linefeed, LF */ +#define XK_Clear 0xff0b +#define XK_Return 0xff0d /* Return, enter */ +#define XK_Pause 0xff13 /* Pause, hold */ +#define XK_Scroll_Lock 0xff14 +#define XK_Sys_Req 0xff15 +#define XK_Escape 0xff1b +#define XK_Delete 0xffff /* Delete, rubout */ +#define XK_Home 0xff50 +#define XK_Left 0xff51 /* Move left, left arrow */ +#define XK_Up 0xff52 /* Move up, up arrow */ +#define XK_Right 0xff53 /* Move right, right arrow */ +#define XK_Down 0xff54 /* Move down, down arrow */ +#define XK_Prior 0xff55 /* Prior, previous */ +#define XK_Page_Up 0xff55 +#define XK_Next 0xff56 /* Next */ +#define XK_Page_Down 0xff56 +#define XK_End 0xff57 /* EOL */ +#define XK_Begin 0xff58 /* BOL */ +#define XK_Select 0xff60 /* Select, mark */ +#define XK_Print 0xff61 +#define XK_Execute 0xff62 /* Execute, run, do */ +#define XK_Insert 0xff63 /* Insert, insert here */ +#define XK_Undo 0xff65 +#define XK_Redo 0xff66 /* Redo, again */ +#define XK_Menu 0xff67 +#define XK_Find 0xff68 /* Find, search */ +#define XK_Cancel 0xff69 /* Cancel, stop, abort, exit */ +#define XK_Help 0xff6a /* Help */ +#define XK_Break 0xff6b +#define XK_Mode_switch 0xff7e /* Character set switch */ +#define XK_script_switch 0xff7e /* Alias for mode_switch */ +#define XK_Num_Lock 0xff7f +#define XK_F1 0xffbe + +#endif /* _HAIKU_SUPPORT_H_ */ diff --git a/src/haikufns.c b/src/haikufns.c new file mode 100644 index 00000000000..868fc71f979 --- /dev/null +++ b/src/haikufns.c @@ -0,0 +1,2448 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include + +#include "lisp.h" +#include "frame.h" +#include "blockinput.h" +#include "termchar.h" +#include "font.h" +#include "keyboard.h" +#include "buffer.h" +#include "dispextern.h" + +#include "haikugui.h" +#include "haikuterm.h" +#include "haiku_support.h" +#include "termhooks.h" + +#include + +#include + +#define RGB_TO_ULONG(r, g, b) \ + (((r) << 16) | ((g) << 8) | (b)); +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) + +/* The frame of the currently visible tooltip. */ +static Lisp_Object tip_frame; + +/* The window-system window corresponding to the frame of the + currently visible tooltip. */ +static Window tip_window; + +/* A timer that hides or deletes the currently visible tooltip when it + fires. */ +static Lisp_Object tip_timer; + +/* STRING argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_string; + +/* Normalized FRAME argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_frame; + +/* PARMS argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_parms; + +static void +haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +static void +haiku_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name); + +static ptrdiff_t image_cache_refcount; + +static Lisp_Object +get_geometry_from_preferences (struct haiku_display_info *dpyinfo, + Lisp_Object parms) +{ + struct { + const char *val; + const char *cls; + Lisp_Object tem; + } r[] = { + { "width", "Width", Qwidth }, + { "height", "Height", Qheight }, + { "left", "Left", Qleft }, + { "top", "Top", Qtop }, + }; + + int i; + for (i = 0; i < ARRAYELTS (r); ++i) + { + if (NILP (Fassq (r[i].tem, parms))) + { + Lisp_Object value + = gui_display_get_arg (dpyinfo, parms, r[i].tem, r[i].val, r[i].cls, + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (r[i].tem, value), parms); + } + } + + return parms; +} + +void +haiku_change_tool_bar_height (struct frame *f, int height) +{ + int unit = FRAME_LINE_HEIGHT (f); + int old_height = FRAME_TOOL_BAR_HEIGHT (f); + int lines = (height + unit - 1) / unit; + Lisp_Object fullscreen = get_frame_param (f, Qfullscreen); + + /* Make sure we redisplay all windows in this frame. */ + fset_redisplay (f); + + FRAME_TOOL_BAR_HEIGHT (f) = height; + FRAME_TOOL_BAR_LINES (f) = lines; + store_frame_param (f, Qtool_bar_lines, make_fixnum (lines)); + + if (FRAME_HAIKU_WINDOW (f) && FRAME_TOOL_BAR_HEIGHT (f) == 0) + { + clear_frame (f); + clear_current_matrices (f); + } + + if ((height < old_height) && WINDOWP (f->tool_bar_window)) + clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix); + + if (!f->tool_bar_resized) + { + /* As long as tool_bar_resized is false, effectively try to change + F's native height. */ + if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth)) + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 1, false, Qtool_bar_lines); + else + adjust_frame_size (f, -1, -1, 4, false, Qtool_bar_lines); + + f->tool_bar_resized = f->tool_bar_redisplayed; + } + else + /* Any other change may leave the native size of F alone. */ + adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_lines); + + /* adjust_frame_size might not have done anything, garbage frame + here. */ + adjust_frame_glyphs (f); + SET_FRAME_GARBAGED (f); + + if (FRAME_HAIKU_WINDOW (f)) + haiku_clear_under_internal_border (f); +} + +void +haiku_change_tab_bar_height (struct frame *f, int height) +{ + int unit = FRAME_LINE_HEIGHT (f); + int old_height = FRAME_TAB_BAR_HEIGHT (f); + int lines = (height + unit - 1) / unit; + Lisp_Object fullscreen = get_frame_param (f, Qfullscreen); + + /* Make sure we redisplay all windows in this frame. */ + fset_redisplay (f); + + /* Recalculate tab bar and frame text sizes. */ + FRAME_TAB_BAR_HEIGHT (f) = height; + FRAME_TAB_BAR_LINES (f) = lines; + store_frame_param (f, Qtab_bar_lines, make_fixnum (lines)); + + if (FRAME_HAIKU_WINDOW (f) && FRAME_TAB_BAR_HEIGHT (f) == 0) + { + clear_frame (f); + clear_current_matrices (f); + } + + if ((height < old_height) && WINDOWP (f->tab_bar_window)) + clear_glyph_matrix (XWINDOW (f->tab_bar_window)->current_matrix); + + if (!f->tab_bar_resized) + { + /* As long as tab_bar_resized is false, effectively try to change + F's native height. */ + if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth)) + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 1, false, Qtab_bar_lines); + else + adjust_frame_size (f, -1, -1, 4, false, Qtab_bar_lines); + + f->tab_bar_resized = f->tab_bar_redisplayed; + } + else + /* Any other change may leave the native size of F alone. */ + adjust_frame_size (f, -1, -1, 3, false, Qtab_bar_lines); + + /* adjust_frame_size might not have done anything, garbage frame + here. */ + adjust_frame_glyphs (f); + SET_FRAME_GARBAGED (f); + if (FRAME_HAIKU_WINDOW (f)) + haiku_clear_under_internal_border (f); +} + +static void +haiku_set_no_focus_on_map (struct frame *f, Lisp_Object value, + Lisp_Object oldval) +{ + if (!EQ (value, oldval)) + FRAME_NO_FOCUS_ON_MAP (f) = !NILP (value); +} + +static void +haiku_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + if (FRAME_TOOLTIP_P (f)) + return; + int nlines; + + /* Treat tool bars like menu bars. */ + if (FRAME_MINIBUF_ONLY_P (f)) + return; + + /* Use VALUE only if an int >= 0. */ + if (RANGED_FIXNUMP (0, value, INT_MAX)) + nlines = XFIXNAT (value); + else + nlines = 0; + + haiku_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); +} + +static void +haiku_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + if (FRAME_TOOLTIP_P (f)) + return; + int olines = FRAME_TAB_BAR_LINES (f); + int nlines; + + /* Treat tab bars like menu bars. */ + if (FRAME_MINIBUF_ONLY_P (f)) + return; + + /* Use VALUE only if an int >= 0. */ + if (RANGED_FIXNUMP (0, value, INT_MAX)) + nlines = XFIXNAT (value); + else + nlines = 0; + + if (nlines != olines && (olines == 0 || nlines == 0)) + haiku_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); +} + + +int +haiku_get_color (const char *name, Emacs_Color *color) +{ + unsigned short r16, g16, b16; + Lisp_Object tem; + + if (parse_color_spec (name, &r16, &g16, &b16)) + { + color->pixel = RGB_TO_ULONG (r16 / 256, g16 / 256, b16 / 256); + color->red = r16; + color->green = g16; + color->blue = b16; + return 0; + } + else + { + block_input (); + eassert (x_display_list && !NILP (x_display_list->color_map)); + tem = x_display_list->color_map; + for (; CONSP (tem); tem = XCDR (tem)) + { + Lisp_Object col = XCAR (tem); + if (CONSP (col) && !xstrcasecmp (SSDATA (XCAR (col)), name)) + { + int32_t clr = XFIXNUM (XCDR (col)); + color->pixel = clr; + color->red = RED_FROM_ULONG (clr) * 257; + color->green = GREEN_FROM_ULONG (clr) * 257; + color->blue = BLUE_FROM_ULONG (clr) * 257; + unblock_input (); + return 0; + } + } + + unblock_input (); + } + + return 1; +} + +static struct haiku_display_info * +haiku_display_info_for_name (Lisp_Object name) +{ + CHECK_STRING (name); + + if (!NILP (Fstring_equal (name, build_string ("be")))) + { + if (!x_display_list) + return x_display_list; + + error ("Be windowing not initialized"); + } + + error ("Be displays can only be named \"be\""); +} + +static struct haiku_display_info * +check_haiku_display_info (Lisp_Object object) +{ + struct haiku_display_info *dpyinfo = NULL; + + if (NILP (object)) + { + struct frame *sf = XFRAME (selected_frame); + + if (FRAME_HAIKU_P (sf) && FRAME_LIVE_P (sf)) + dpyinfo = FRAME_DISPLAY_INFO (sf); + else if (x_display_list) + dpyinfo = x_display_list; + else + error ("Be windowing not present"); + } + else if (TERMINALP (object)) + { + struct terminal *t = decode_live_terminal (object); + + if (t->type != output_haiku) + error ("Terminal %d is not a Be display", t->id); + + dpyinfo = t->display_info.haiku; + } + else if (STRINGP (object)) + dpyinfo = haiku_display_info_for_name (object); + else + { + struct frame *f = decode_window_system_frame (object); + dpyinfo = FRAME_DISPLAY_INFO (f); + } + + return dpyinfo; +} + +static void +haiku_set_title_bar_text (struct frame *f, Lisp_Object text) +{ + if (FRAME_HAIKU_WINDOW (f)) + { + block_input (); + BWindow_retitle (FRAME_HAIKU_WINDOW (f), SSDATA (ENCODE_UTF_8 (text))); + unblock_input (); + } +} + +static void +haiku_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name) +{ + /* Don't change the title if it's already NAME. */ + if (EQ (name, f->title)) + return; + + update_mode_lines = 26; + + fset_title (f, name); + + if (NILP (name)) + name = f->name; + + haiku_set_title_bar_text (f, name); +} + +static void +haiku_set_child_frame_border_width (struct frame *f, + Lisp_Object arg, Lisp_Object oldval) +{ + int border; + + if (NILP (arg)) + border = -1; + else if (RANGED_FIXNUMP (0, arg, INT_MAX)) + border = XFIXNAT (arg); + else + signal_error ("Invalid child frame border width", arg); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + + if (FRAME_HAIKU_WINDOW (f)) + adjust_frame_size (f, -1, -1, 3, 0, Qchild_frame_border_width); + + SET_FRAME_GARBAGED (f); + } +} + +static void +haiku_set_parent_frame (struct frame *f, + Lisp_Object new_value, Lisp_Object old_value) +{ + struct frame *p = NULL; + block_input (); + if (!NILP (new_value) + && (!FRAMEP (new_value) + || !FRAME_LIVE_P (p = XFRAME (new_value)) + || !FRAME_HAIKU_P (p))) + { + store_frame_param (f, Qparent_frame, old_value); + unblock_input (); + error ("Invalid specification of `parent-frame'"); + } + + if (EQ (new_value, old_value)) + { + unblock_input (); + return; + } + + if (!NILP (old_value)) + EmacsWindow_unparent (FRAME_HAIKU_WINDOW (f)); + if (!NILP (new_value)) + { + EmacsWindow_parent_to (FRAME_HAIKU_WINDOW (f), + FRAME_HAIKU_WINDOW (p)); + BWindow_set_offset (FRAME_HAIKU_WINDOW (f), + f->left_pos, f->top_pos); + } + fset_parent_frame (f, new_value); + unblock_input (); +} + +static void +haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + haiku_set_name (f, arg, 1); +} + +static void +haiku_set_no_accept_focus (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) +{ + block_input (); + if (!EQ (new_value, old_value)) + FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value); + + if (FRAME_HAIKU_WINDOW (f)) + { + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), + FRAME_NO_ACCEPT_FOCUS (f)); + } + unblock_input (); +} + +static void +unwind_create_frame (Lisp_Object frame) +{ + struct frame *f = XFRAME (frame); + + /* If frame is already dead, nothing to do. This can happen if the + display is disconnected after the frame has become official, but + before x_create_frame removes the unwind protect. */ + if (!FRAME_LIVE_P (f)) + return; + + /* If frame is ``official'', nothing to do. */ + if (NILP (Fmemq (frame, Vframe_list))) + { +#if defined GLYPH_DEBUG && defined ENABLE_CHECKING + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); +#endif + + /* If the frame's image cache refcount is still the same as our + private shadow variable, it means we are unwinding a frame + for which we didn't yet call init_frame_faces, where the + refcount is incremented. Therefore, we increment it here, so + that free_frame_faces, called in free_frame_resources later, + will not mistakenly decrement the counter that was not + incremented yet to account for this new frame. */ + if (FRAME_IMAGE_CACHE (f) != NULL + && FRAME_IMAGE_CACHE (f)->refcount == image_cache_refcount) + FRAME_IMAGE_CACHE (f)->refcount++; + + haiku_free_frame_resources (f); + free_glyphs (f); + +#if defined GLYPH_DEBUG && defined ENABLE_CHECKING + /* Check that reference counts are indeed correct. */ + if (dpyinfo->terminal->image_cache) + eassert (dpyinfo->terminal->image_cache->refcount == image_cache_refcount); +#endif + } +} + +static void +unwind_create_tip_frame (Lisp_Object frame) +{ + unwind_create_frame (frame); + tip_window = NULL; + tip_frame = Qnil; +} + +static void +haiku_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + struct haiku_output *output = FRAME_OUTPUT_DATA (f); + unsigned long old_fg; + + Emacs_Color color; + + if (haiku_get_color (SSDATA (arg), &color)) + { + store_frame_param (f, Qforeground_color, oldval); + unblock_input (); + error ("Bad color"); + } + + old_fg = FRAME_FOREGROUND_PIXEL (f); + FRAME_FOREGROUND_PIXEL (f) = color.pixel; + + if (FRAME_HAIKU_WINDOW (f)) + { + + block_input (); + if (output->cursor_color.pixel == old_fg) + { + output->cursor_color.pixel = old_fg; + output->cursor_color.red = RED_FROM_ULONG (old_fg); + output->cursor_color.green = GREEN_FROM_ULONG (old_fg); + output->cursor_color.blue = BLUE_FROM_ULONG (old_fg); + } + + unblock_input (); + + update_face_from_frame_parameter (f, Qforeground_color, arg); + + if (FRAME_VISIBLE_P (f)) + redraw_frame (f); + } +} + +static void +unwind_popup (void) +{ + if (!popup_activated_p) + emacs_abort (); + --popup_activated_p; +} + +static Lisp_Object +haiku_create_frame (Lisp_Object parms, int ttip_p) +{ + struct frame *f; + Lisp_Object frame, tem; + Lisp_Object name; + bool minibuffer_only = false; + bool face_change_before = face_change; + long window_prompting = 0; + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object display; + struct haiku_display_info *dpyinfo = NULL; + struct kboard *kb; + + parms = Fcopy_alist (parms); + + Vx_resource_name = Vinvocation_name; + + display = gui_display_get_arg (dpyinfo, parms, Qterminal, 0, 0, + RES_TYPE_STRING); + if (EQ (display, Qunbound)) + display = Qnil; + dpyinfo = check_haiku_display_info (display); + kb = dpyinfo->terminal->kboard; + + if (!dpyinfo->terminal->name) + error ("Terminal is not live, can't create new frames on it"); + + name = gui_display_get_arg (dpyinfo, parms, Qname, 0, 0, + RES_TYPE_STRING); + if (!STRINGP (name) + && ! EQ (name, Qunbound) + && ! NILP (name)) + error ("Invalid frame name--not a string or nil"); + + if (STRINGP (name)) + Vx_resource_name = name; + + block_input (); + + /* make_frame_without_minibuffer can run Lisp code and garbage collect. */ + /* No need to protect DISPLAY because that's not used after passing + it to make_frame_without_minibuffer. */ + frame = Qnil; + tem = gui_display_get_arg (dpyinfo, parms, Qminibuffer, + "minibuffer", "Minibuffer", + RES_TYPE_SYMBOL); + if (ttip_p) + f = make_frame (0); + else if (EQ (tem, Qnone) || NILP (tem)) + f = make_frame_without_minibuffer (Qnil, kb, display); + else if (EQ (tem, Qonly)) + { + f = make_minibuffer_frame (); + minibuffer_only = 1; + } + else if (WINDOWP (tem)) + f = make_frame_without_minibuffer (tem, kb, display); + else + f = make_frame (1); + XSETFRAME (frame, f); + + f->terminal = dpyinfo->terminal; + + f->output_method = output_haiku; + f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku); + + f->output_data.haiku->pending_zoom_x = INT_MIN; + f->output_data.haiku->pending_zoom_y = INT_MIN; + f->output_data.haiku->pending_zoom_width = INT_MIN; + f->output_data.haiku->pending_zoom_height = INT_MIN; + + if (ttip_p) + f->wants_modeline = false; + + fset_icon_name (f, gui_display_get_arg (dpyinfo, parms, Qicon_name, + "iconName", "Title", + RES_TYPE_STRING)); + if (! STRINGP (f->icon_name) || ttip_p) + fset_icon_name (f, Qnil); + + FRAME_DISPLAY_INFO (f) = dpyinfo; + + /* With FRAME_DISPLAY_INFO set up, this unwind-protect is safe. */ + if (!ttip_p) + record_unwind_protect (unwind_create_frame, frame); + else + record_unwind_protect (unwind_create_tip_frame, frame); + + FRAME_OUTPUT_DATA (f)->parent_desc = NULL; + FRAME_OUTPUT_DATA (f)->explicit_parent = 0; + + /* Set the name; the functions to which we pass f expect the name to + be set. */ + if (EQ (name, Qunbound) || NILP (name) || ! STRINGP (name)) + { + fset_name (f, Vinvocation_name); + f->explicit_name = 0; + } + else + { + fset_name (f, name); + f->explicit_name = 1; + specbind (Qx_resource_name, name); + } + +#ifdef USE_BE_CAIRO + register_font_driver (&ftcrfont_driver, f); +#ifdef HAVE_HARFBUZZ + register_font_driver (&ftcrhbfont_driver, f); +#endif +#endif + register_font_driver (&haikufont_driver, f); + + f->tooltip = ttip_p; + + image_cache_refcount = + FRAME_IMAGE_CACHE (f) ? FRAME_IMAGE_CACHE (f)->refcount : 0; + + gui_default_parameter (f, parms, Qfont_backend, Qnil, + "fontBackend", "FontBackend", RES_TYPE_STRING); + + FRAME_RIF (f)->default_font_parameter (f, parms); + + unblock_input (); + + gui_default_parameter (f, parms, Qborder_width, make_fixnum (0), + "borderwidth", "BorderWidth", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (ttip_p ? 1 : 2), + "internalBorderWidth", "InternalBorderWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qchild_frame_border_width, Qnil, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qvertical_scroll_bars, !ttip_p ? Qt : Qnil, + "verticalScrollBars", "VerticalScrollBars", + RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qhorizontal_scroll_bars, Qnil, + "horizontalScrollBars", "HorizontalScrollBars", + RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qforeground_color, build_string ("black"), + "foreground", "Foreground", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qbackground_color, build_string ("white"), + "background", "Background", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qline_spacing, Qnil, + "lineSpacing", "LineSpacing", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qleft_fringe, Qnil, + "leftFringe", "LeftFringe", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qright_fringe, Qnil, + "rightFringe", "RightFringe", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qno_special_glyphs, ttip_p ? Qnil : Qt, + NULL, NULL, RES_TYPE_BOOLEAN); + + init_frame_faces (f); + + /* Read comment about this code in corresponding place in xfns.c. */ + tem = gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, + RES_TYPE_NUMBER); + if (FIXNUMP (tem)) + store_frame_param (f, Qmin_width, tem); + tem = gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, + RES_TYPE_NUMBER); + if (FIXNUMP (tem)) + store_frame_param (f, Qmin_height, tem); + adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), + FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, + Qx_create_frame_1); + + if (!ttip_p) + { + gui_default_parameter (f, parms, Qz_group, Qnil, NULL, NULL, RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qno_focus_on_map, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qno_accept_focus, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + + /* The resources controlling the menu-bar, tool-bar, and tab-bar are + processed specially at startup, and reflected in the mode + variables; ignore them here. */ + gui_default_parameter (f, parms, Qmenu_bar_lines, + NILP (Vmenu_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qtab_bar_lines, + NILP (Vtab_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qtool_bar_lines, + NILP (Vtool_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qbuffer_predicate, Qnil, "bufferPredicate", + "BufferPredicate", RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qtitle, Qnil, "title", "Title", + RES_TYPE_STRING); + } + + parms = get_geometry_from_preferences (dpyinfo, parms); + window_prompting = gui_figure_window_size (f, parms, false, true); + + if (ttip_p) + { + /* No fringes on tip frame. */ + f->fringe_cols = 0; + f->left_fringe_width = 0; + f->right_fringe_width = 0; + /* No dividers on tip frame. */ + f->right_divider_width = 0; + f->bottom_divider_width = 0; + } + + tem = gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0, + RES_TYPE_BOOLEAN); + f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem)); + + /* Add `tooltip' frame parameter's default value. */ + if (NILP (Fframe_parameter (frame, Qtooltip)) && ttip_p) + Fmodify_frame_parameters (frame, Fcons (Fcons (Qtooltip, Qt), Qnil)); + +#define ASSIGN_CURSOR(cursor, be_cursor) \ + (FRAME_OUTPUT_DATA (f)->cursor = be_cursor) + + ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ()); + ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ()); + ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ()); + ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ()); + ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ()); + ASSIGN_CURSOR (horizontal_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST)); + ASSIGN_CURSOR (vertical_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH)); + ASSIGN_CURSOR (left_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_WEST)); + ASSIGN_CURSOR (top_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST)); + ASSIGN_CURSOR (top_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH)); + ASSIGN_CURSOR (top_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST)); + ASSIGN_CURSOR (right_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST)); + ASSIGN_CURSOR (bottom_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST)); + ASSIGN_CURSOR (bottom_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH)); + ASSIGN_CURSOR (bottom_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST)); + ASSIGN_CURSOR (no_cursor, + BCursor_from_id (CURSOR_ID_NO_CURSOR)); + + ASSIGN_CURSOR (current_cursor, FRAME_OUTPUT_DATA (f)->text_cursor); +#undef ASSIGN_CURSOR + + + if (ttip_p) + f->no_split = true; + f->terminal->reference_count++; + + FRAME_OUTPUT_DATA (f)->window = BWindow_new (&FRAME_OUTPUT_DATA (f)->view); + if (!FRAME_OUTPUT_DATA (f)->window) + xsignal1 (Qerror, build_unibyte_string ("Could not create window")); + + if (!minibuffer_only && !ttip_p && FRAME_EXTERNAL_MENU_BAR (f)) + initialize_frame_menubar (f); + + FRAME_OUTPUT_DATA (f)->window_desc = FRAME_OUTPUT_DATA (f)->window; + + Vframe_list = Fcons (frame, Vframe_list); + + Lisp_Object parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, + RES_TYPE_SYMBOL); + + if (EQ (parent_frame, Qunbound) + || NILP (parent_frame) + || !FRAMEP (parent_frame) + || !FRAME_LIVE_P (XFRAME (parent_frame))) + parent_frame = Qnil; + + fset_parent_frame (f, parent_frame); + store_frame_param (f, Qparent_frame, parent_frame); + + if (!NILP (parent_frame)) + haiku_set_parent_frame (f, parent_frame, Qnil); + + gui_default_parameter (f, parms, Qundecorated, Qnil, NULL, NULL, RES_TYPE_BOOLEAN); + + gui_default_parameter (f, parms, Qicon_type, Qnil, + "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL); + if (ttip_p) + { + gui_default_parameter (f, parms, Qundecorated, Qt, NULL, NULL, RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qno_accept_focus, Qt, NULL, NULL, + RES_TYPE_BOOLEAN); + } + else + { + gui_default_parameter (f, parms, Qauto_raise, Qnil, + "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qauto_lower, Qnil, + "autoLower", "AutoLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qcursor_type, Qbox, + "cursorType", "CursorType", RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qscroll_bar_width, Qnil, + "scrollBarWidth", "ScrollBarWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qscroll_bar_height, Qnil, + "scrollBarHeight", "ScrollBarHeight", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qalpha, Qnil, + "alpha", "Alpha", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qfullscreen, Qnil, + "fullscreen", "Fullscreen", RES_TYPE_SYMBOL); + } + + gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); + + if (ttip_p) + { + Lisp_Object bg = Fframe_parameter (frame, Qbackground_color); + + call2 (Qface_set_after_frame_default, frame, Qnil); + + if (!EQ (bg, Fframe_parameter (frame, Qbackground_color))) + { + AUTO_FRAME_ARG (arg, Qbackground_color, bg); + Fmodify_frame_parameters (frame, arg); + } + } + + if (ttip_p) + face_change = face_change_before; + + f->can_set_window_size = true; + + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 0, true, ttip_p ? Qtip_frame : Qx_create_frame_2); + + if (!FRAME_OUTPUT_DATA (f)->explicit_parent && !ttip_p) + { + Lisp_Object visibility; + + visibility = gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0, + RES_TYPE_SYMBOL); + if (EQ (visibility, Qunbound)) + visibility = Qt; + if (EQ (visibility, Qicon)) + haiku_iconify_frame (f); + else if (!NILP (visibility)) + haiku_visualize_frame (f); + else /* Qnil */ + { + f->was_invisible = true; + } + } + + if (!ttip_p) + { + if (FRAME_HAS_MINIBUF_P (f) + && (!FRAMEP (KVAR (kb, Vdefault_minibuffer_frame)) + || !FRAME_LIVE_P (XFRAME (KVAR (kb, Vdefault_minibuffer_frame))))) + kset_default_minibuffer_frame (kb, frame); + } + + for (tem = parms; CONSP (tem); tem = XCDR (tem)) + if (CONSP (XCAR (tem)) && !NILP (XCAR (XCAR (tem)))) + fset_param_alist (f, Fcons (XCAR (tem), f->param_alist)); + + if (window_prompting & (USPosition | PPosition)) + haiku_set_offset (f, f->left_pos, f->top_pos, 1); + else + BWindow_center_on_screen (FRAME_HAIKU_WINDOW (f)); + + /* Make sure windows on this frame appear in calls to next-window + and similar functions. */ + Vwindow_list = Qnil; + + if (ttip_p) + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 0, true, Qtip_frame); + + return unbind_to (count, frame); +} + +static void +compute_tip_xy (struct frame *f, + Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, + int width, int height, int *root_x, int *root_y) +{ + Lisp_Object left, top, right, bottom; + int min_x = 0, min_y = 0, max_x = 0, max_y = 0; + + /* User-specified position? */ + left = Fcdr (Fassq (Qleft, parms)); + top = Fcdr (Fassq (Qtop, parms)); + right = Fcdr (Fassq (Qright, parms)); + bottom = Fcdr (Fassq (Qbottom, parms)); + + /* Move the tooltip window where the mouse pointer is. Resize and + show it. */ + if ((!FIXNUMP (left) && !FIXNUMP (right)) + || (!FIXNUMP (top) && !FIXNUMP (bottom))) + { + int x, y; + + /* Default min and max values. */ + min_x = 0; + min_y = 0; + BScreen_px_dim (&max_x, &max_y); + + block_input (); + BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y); + BView_convert_to_screen (FRAME_HAIKU_VIEW (f), &x, &y); + *root_x = x; + *root_y = y; + unblock_input (); + } + + if (FIXNUMP (top)) + *root_y = XFIXNUM (top); + else if (FIXNUMP (bottom)) + *root_y = XFIXNUM (bottom) - height; + else if (*root_y + XFIXNUM (dy) <= min_y) + *root_y = min_y; /* Can happen for negative dy */ + else if (*root_y + XFIXNUM (dy) + height <= max_y) + /* It fits below the pointer */ + *root_y += XFIXNUM (dy); + else if (height + XFIXNUM (dy) + min_y <= *root_y) + /* It fits above the pointer. */ + *root_y -= height + XFIXNUM (dy); + else + /* Put it on the top. */ + *root_y = min_y; + + if (FIXNUMP (left)) + *root_x = XFIXNUM (left); + else if (FIXNUMP (right)) + *root_x = XFIXNUM (right) - width; + else if (*root_x + XFIXNUM (dx) <= min_x) + *root_x = 0; /* Can happen for negative dx */ + else if (*root_x + XFIXNUM (dx) + width <= max_x) + /* It fits to the right of the pointer. */ + *root_x += XFIXNUM (dx); + else if (width + XFIXNUM (dx) + min_x <= *root_x) + /* It fits to the left of the pointer. */ + *root_x -= width + XFIXNUM (dx); + else + /* Put it left justified on the screen -- it ought to fit that way. */ + *root_x = min_x; +} + +static Lisp_Object +haiku_hide_tip (bool delete) +{ + if (!NILP (tip_timer)) + { + call1 (Qcancel_timer, tip_timer); + tip_timer = Qnil; + } + + Lisp_Object it, frame; + FOR_EACH_FRAME (it, frame) + if (FRAME_WINDOW_P (XFRAME (frame)) && + FRAME_HAIKU_VIEW (XFRAME (frame))) + BView_set_tooltip (FRAME_HAIKU_VIEW (XFRAME (frame)), NULL); + + if (NILP (tip_frame) + || (!delete && !NILP (tip_frame) + && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + return Qnil; + else + { + ptrdiff_t count; + Lisp_Object was_open = Qnil; + + count = SPECPDL_INDEX (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + + if (!NILP (tip_frame)) + { + if (FRAME_LIVE_P (XFRAME (tip_frame))) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + haiku_unvisualize_frame (XFRAME (tip_frame)); + + was_open = Qt; + } + else + tip_frame = Qnil; + } + else + tip_frame = Qnil; + + return unbind_to (count, was_open); + } +} + +static void +haiku_set_undecorated (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + if (EQ (new_value, old_value)) + return; + + block_input (); + FRAME_UNDECORATED (f) = !NILP (new_value); + BWindow_change_decoration (FRAME_HAIKU_WINDOW (f), NILP (new_value)); + unblock_input (); +} + +static void +haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + if (FRAME_TOOLTIP_P (f)) + return; + int nlines; + if (TYPE_RANGED_FIXNUMP (int, value)) + nlines = XFIXNUM (value); + else + nlines = 0; + + fset_redisplay (f); + + FRAME_MENU_BAR_LINES (f) = 0; + FRAME_MENU_BAR_HEIGHT (f) = 0; + + if (nlines) + { + FRAME_EXTERNAL_MENU_BAR (f) = 1; + if (FRAME_HAIKU_P (f) && !FRAME_HAIKU_MENU_BAR (f)) + XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = 1; + } + else + { + if (FRAME_EXTERNAL_MENU_BAR (f)) + free_frame_menubar (f); + FRAME_EXTERNAL_MENU_BAR (f) = 0; + if (FRAME_HAIKU_P (f)) + FRAME_HAIKU_MENU_BAR (f) = 0; + } + + adjust_frame_glyphs (f); +} + +/* Return geometric attributes of FRAME. According to the value of + ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the inner + edges of FRAME, the root window edges of frame (Qroot_edges). Any + other value means to return the geometry as returned by + Fx_frame_geometry. */ +static Lisp_Object +frame_geometry (Lisp_Object frame, Lisp_Object attribute) +{ + struct frame *f = decode_live_frame (frame); + check_window_system (f); + + if (EQ (attribute, Qouter_edges)) + return list4i (f->left_pos, f->top_pos, + f->left_pos, f->top_pos); + else if (EQ (attribute, Qnative_edges)) + return list4i (f->left_pos, f->top_pos, + f->left_pos + FRAME_PIXEL_WIDTH (f), + f->top_pos + FRAME_PIXEL_HEIGHT (f)); + else if (EQ (attribute, Qinner_edges)) + return list4i (f->left_pos + FRAME_INTERNAL_BORDER_WIDTH (f), + f->top_pos + FRAME_INTERNAL_BORDER_WIDTH (f) + + FRAME_MENU_BAR_HEIGHT (f) + FRAME_TOOL_BAR_HEIGHT (f), + f->left_pos - FRAME_INTERNAL_BORDER_WIDTH (f) + + FRAME_PIXEL_WIDTH (f), + f->top_pos + FRAME_PIXEL_HEIGHT (f) - + FRAME_INTERNAL_BORDER_WIDTH (f)); + + else + return + list (Fcons (Qouter_position, + Fcons (make_fixnum (f->left_pos), + make_fixnum (f->top_pos))), + Fcons (Qouter_size, + Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f)), + make_fixnum (FRAME_PIXEL_HEIGHT (f)))), + Fcons (Qexternal_border_size, + Fcons (make_fixnum (0), make_fixnum (0))), + Fcons (Qtitle_bar_size, + Fcons (make_fixnum (0), make_fixnum (0))), + Fcons (Qmenu_bar_external, Qnil), + Fcons (Qmenu_bar_size, Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f) - + (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)), + make_fixnum (FRAME_MENU_BAR_HEIGHT (f)))), + Fcons (Qtool_bar_external, Qnil), + Fcons (Qtool_bar_position, Qtop), + Fcons (Qtool_bar_size, Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f) - + (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)), + make_fixnum (FRAME_TOOL_BAR_HEIGHT (f)))), + Fcons (Qinternal_border_width, make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f)))); +} + +void +haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + CHECK_STRING (arg); + + block_input (); + Emacs_Color color; + + if (haiku_get_color (SSDATA (arg), &color)) + { + store_frame_param (f, Qbackground_color, oldval); + unblock_input (); + error ("Bad color"); + } + + FRAME_OUTPUT_DATA (f)->cursor_fg = color.pixel; + FRAME_BACKGROUND_PIXEL (f) = color.pixel; + + if (FRAME_HAIKU_VIEW (f)) + { + struct face *defface; + + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + BView_SetViewColor (FRAME_HAIKU_VIEW (f), color.pixel); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + + defface = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); + if (defface) + { + defface->background = color.pixel; + update_face_from_frame_parameter (f, Qbackground_color, arg); + clear_frame (f); + } + } + + if (FRAME_VISIBLE_P (f)) + SET_FRAME_GARBAGED (f); + unblock_input (); +} + +void +haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + CHECK_STRING (arg); + + block_input (); + Emacs_Color color; + + if (haiku_get_color (SSDATA (arg), &color)) + { + store_frame_param (f, Qcursor_color, oldval); + unblock_input (); + error ("Bad color"); + } + + FRAME_CURSOR_COLOR (f) = color; + if (FRAME_VISIBLE_P (f)) + { + gui_update_cursor (f, 0); + gui_update_cursor (f, 1); + } + update_face_from_frame_parameter (f, Qcursor_color, arg); + unblock_input (); +} + +void +haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + set_frame_cursor_types (f, arg); +} + +unsigned long +haiku_get_pixel (haiku bitmap, int x, int y) +{ + unsigned char *data; + int32_t bytes_per_row; + int mono_p; + int left; + int right; + int top; + int bottom; + + data = BBitmap_data (bitmap); + BBitmap_dimensions (bitmap, &left, &top, &right, &bottom, + &bytes_per_row, &mono_p); + + if (x < left || x > right || y < top || y > bottom) + emacs_abort (); + + if (!mono_p) + return ((uint32_t *) (data + (bytes_per_row * y)))[x]; + + int byte = y * bytes_per_row + x / 8; + return data[byte] & (1 << (x % 8)); +} + +void +haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel) +{ + unsigned char *data; + int32_t bytes_per_row; + int mono_p; + int left; + int right; + int top; + int bottom; + + data = BBitmap_data (bitmap); + BBitmap_dimensions (bitmap, &left, &top, &right, &bottom, + &bytes_per_row, &mono_p); + + if (x < left || x > right || y < top || y > bottom) + emacs_abort (); + + if (mono_p) + { + ptrdiff_t off = y * bytes_per_row; + ptrdiff_t bit = x % 8; + ptrdiff_t xoff = x / 8; + + unsigned char *byte = data + off + xoff; + if (!pixel) + *byte &= ~(1 << bit); + else + *byte |= 1 << bit; + } + else + ((uint32_t *) (data + (bytes_per_row * y)))[x] = pixel; +} + +void +haiku_free_frame_resources (struct frame *f) +{ + haiku window, drawable, mbar; + Mouse_HLInfo *hlinfo; + struct haiku_display_info *dpyinfo; + Lisp_Object bar; + struct scroll_bar *b; + + block_input (); + check_window_system (f); + + hlinfo = MOUSE_HL_INFO (f); + window = FRAME_HAIKU_WINDOW (f); + drawable = FRAME_HAIKU_VIEW (f); + mbar = FRAME_HAIKU_MENU_BAR (f); + dpyinfo = FRAME_DISPLAY_INFO (f); + + free_frame_faces (f); + + /* Free scroll bars */ + for (bar = FRAME_SCROLL_BARS (f); !NILP (bar); bar = b->next) + { + b = XSCROLL_BAR (bar); + haiku_scroll_bar_remove (b); + } + + if (f == dpyinfo->highlight_frame) + dpyinfo->highlight_frame = 0; + if (f == dpyinfo->focused_frame) + dpyinfo->focused_frame = 0; + if (f == dpyinfo->last_mouse_motion_frame) + dpyinfo->last_mouse_motion_frame = NULL; + if (f == dpyinfo->last_mouse_frame) + dpyinfo->last_mouse_frame = NULL; + if (f == dpyinfo->focus_event_frame) + dpyinfo->focus_event_frame = NULL; + + if (f == hlinfo->mouse_face_mouse_frame) + reset_mouse_highlight (hlinfo); + + if (mbar) + { + BMenuBar_delete (mbar); + if (f->output_data.haiku->menu_bar_open_p) + { + --popup_activated_p; + f->output_data.haiku->menu_bar_open_p = 0; + } + } + + if (drawable) + BView_emacs_delete (drawable); + + if (window) + BWindow_quit (window); + + /* Free cursors */ + + BCursor_delete (f->output_data.haiku->text_cursor); + BCursor_delete (f->output_data.haiku->nontext_cursor); + BCursor_delete (f->output_data.haiku->modeline_cursor); + BCursor_delete (f->output_data.haiku->hand_cursor); + BCursor_delete (f->output_data.haiku->hourglass_cursor); + BCursor_delete (f->output_data.haiku->horizontal_drag_cursor); + BCursor_delete (f->output_data.haiku->vertical_drag_cursor); + BCursor_delete (f->output_data.haiku->left_edge_cursor); + BCursor_delete (f->output_data.haiku->top_left_corner_cursor); + BCursor_delete (f->output_data.haiku->top_edge_cursor); + BCursor_delete (f->output_data.haiku->top_right_corner_cursor); + BCursor_delete (f->output_data.haiku->right_edge_cursor); + BCursor_delete (f->output_data.haiku->bottom_right_corner_cursor); + BCursor_delete (f->output_data.haiku->bottom_edge_cursor); + BCursor_delete (f->output_data.haiku->bottom_left_corner_cursor); + BCursor_delete (f->output_data.haiku->no_cursor); + + xfree (FRAME_OUTPUT_DATA (f)); + FRAME_OUTPUT_DATA (f) = NULL; + + unblock_input (); +} + +void +haiku_iconify_frame (struct frame *frame) +{ + if (FRAME_ICONIFIED_P (frame)) + return; + + block_input (); + + SET_FRAME_VISIBLE (frame, false); + SET_FRAME_ICONIFIED (frame, true); + + BWindow_iconify (FRAME_HAIKU_WINDOW (frame)); + + unblock_input (); +} + +void +haiku_visualize_frame (struct frame *f) +{ + block_input (); + + if (!FRAME_VISIBLE_P (f)) + { + if (FRAME_NO_FOCUS_ON_MAP (f)) + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), 1); + BWindow_set_visible (FRAME_HAIKU_WINDOW (f), 1); + if (FRAME_NO_FOCUS_ON_MAP (f) && + !FRAME_NO_ACCEPT_FOCUS (f)) + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), 0); + + haiku_set_offset (f, f->left_pos, f->top_pos, 0); + + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, 0); + } + + unblock_input (); +} + +void +haiku_unvisualize_frame (struct frame *f) +{ + block_input (); + + BWindow_set_visible (FRAME_HAIKU_WINDOW (f), 0); + SET_FRAME_VISIBLE (f, 0); + SET_FRAME_ICONIFIED (f, 0); + + unblock_input (); +} + +void +haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); + int new_width = check_int_nonnegative (arg); + + if (new_width == old_width) + return; + f->internal_border_width = new_width; + + if (FRAME_HAIKU_WINDOW (f)) + { + adjust_frame_size (f, -1, -1, 3, 0, Qinternal_border_width); + haiku_clear_under_internal_border (f); + } + + SET_FRAME_GARBAGED (f); +} + +void +haiku_set_frame_visible_invisible (struct frame *f, bool visible_p) +{ + if (visible_p) + haiku_visualize_frame (f); + else + haiku_unvisualize_frame (f); +} + +void +frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) +{ + block_input (); + + BView_convert_to_screen (FRAME_HAIKU_VIEW (f), &pix_x, &pix_y); + be_warp_pointer (pix_x, pix_y); + + unblock_input (); +} + +void +haiku_query_color (uint32_t col, Emacs_Color *color_def) +{ + color_def->red = RED_FROM_ULONG (col) * 257; + color_def->green = GREEN_FROM_ULONG (col) * 257; + color_def->blue = BLUE_FROM_ULONG (col) * 257; + + color_def->pixel = col; +} + +Display_Info * +check_x_display_info (Lisp_Object object) +{ + return check_haiku_display_info (object); +} + +/* Rename frame F to NAME. If NAME is nil, set F's name to "GNU + Emacs". If EXPLICIT_P is non-zero, that indicates Lisp code is + setting the name, not redisplay; in that case, set F's name to NAME + and set F->explicit_name; if NAME is nil, clear F->explicit_name. + + If EXPLICIT_P is zero, it means redisplay is setting the name; the + name provided will be ignored if explicit_name is set. */ +void +haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p) +{ + if (explicit_p) + { + if (f->explicit_name && NILP (name)) + update_mode_lines = 24; + + f->explicit_name = !NILP (name); + } + else if (f->explicit_name) + return; + + if (NILP (name)) + name = build_unibyte_string ("GNU Emacs"); + + if (!NILP (Fstring_equal (name, f->name))) + return; + + fset_name (f, name); + + if (!NILP (f->title)) + name = f->title; + + haiku_set_title_bar_text (f, name); +} + +static void +haiku_set_inhibit_double_buffering (struct frame *f, + Lisp_Object new_value, + Lisp_Object old_value) +{ + block_input (); + if (FRAME_HAIKU_WINDOW (f)) + { + if (NILP (new_value)) + { + EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f)); + if (!NILP (old_value)) + { + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } + } + else + EmacsView_disable_double_buffering (FRAME_HAIKU_VIEW (f)); + } + unblock_input (); +} + + + +DEFUN ("haiku-set-mouse-absolute-pixel-position", + Fhaiku_set_mouse_absolute_pixel_position, + Shaiku_set_mouse_absolute_pixel_position, 2, 2, 0, + doc: /* Move mouse pointer to a pixel position at (X, Y). The +coordinates X and Y are interpreted to start from the top-left +corner of the screen. */) + (Lisp_Object x, Lisp_Object y) +{ + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); + + if (!x_display_list) + error ("Window system not initialized"); + + block_input (); + be_warp_pointer (xval, yval); + unblock_input (); + return Qnil; +} + +DEFUN ("haiku-mouse-absolute-pixel-position", Fhaiku_mouse_absolute_pixel_position, + Shaiku_mouse_absolute_pixel_position, 0, 0, 0, + doc: /* Return absolute position of mouse cursor in pixels. +The position is returned as a cons cell (X . Y) of the coordinates of +the mouse cursor position in pixels relative to a position (0, 0) of the +selected frame's display. */) + (void) +{ + if (!x_display_list) + return Qnil; + + struct frame *f = SELECTED_FRAME (); + + if (FRAME_INITIAL_P (f) || !FRAME_HAIKU_P (f) + || !FRAME_HAIKU_VIEW (f)) + return Qnil; + + block_input (); + void *view = FRAME_HAIKU_VIEW (f); + + int x, y; + BView_get_mouse (view, &x, &y); + BView_convert_to_screen (view, &x, &y); + unblock_input (); + + return Fcons (make_fixnum (x), make_fixnum (y)); +} + +DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + return Qt; +} + +DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object color, Lisp_Object frame) +{ + Emacs_Color col; + CHECK_STRING (color); + decode_window_system_frame (frame); + + return haiku_get_color (SSDATA (color), &col) ? Qnil : Qt; +} + +DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object color, Lisp_Object frame) +{ + Emacs_Color col; + CHECK_STRING (color); + decode_window_system_frame (frame); + + block_input (); + if (haiku_get_color (SSDATA (color), &col)) + { + unblock_input (); + return Qnil; + } + unblock_input (); + return list3i (lrint (col.red), lrint (col.green), lrint (col.blue)); +} + +DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + return Qnil; +} + +DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, + 1, 3, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed) +{ + struct haiku_display_info *dpy_info; + CHECK_STRING (display); + + if (NILP (Fstring_equal (display, build_string ("be")))) + !NILP (must_succeed) ? fatal ("Bad display") : error ("Bad display"); + dpy_info = haiku_term_init (); + + if (!dpy_info) + !NILP (must_succeed) ? fatal ("Display not responding") : + error ("Display not responding"); + + return Qnil; +} + +DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) + +{ + check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + return make_fixnum (width); +} + +DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) + +{ + check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + return make_fixnum (width); +} + +DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + + return make_fixnum (height / (dpyinfo->resy / 25.4)); +} + + +DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + + return make_fixnum (height / (dpyinfo->resy / 25.4)); +} + +DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, + 1, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object parms) +{ + return haiku_create_frame (parms, 0); +} + +DEFUN ("x-display-visual-class", Fx_display_visual_class, + Sx_display_visual_class, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + int planes = be_get_display_planes (); + + if (planes == 8) + return intern ("static-color"); + else if (planes == 16 || planes == 15) + return intern ("pseudo-color"); + + return intern ("direct-color"); +} + +DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) +{ + struct frame *tip_f; + struct window *w; + int root_x, root_y; + struct buffer *old_buffer; + struct text_pos pos; + int width, height; + int old_windows_or_buffers_changed = windows_or_buffers_changed; + ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count_1; + Lisp_Object window, size, tip_buf; + + AUTO_STRING (tip, " *tip*"); + + specbind (Qinhibit_redisplay, Qt); + + CHECK_STRING (string); + + if (NILP (frame)) + frame = selected_frame; + decode_window_system_frame (frame); + + if (NILP (timeout)) + timeout = make_fixnum (5); + else + CHECK_FIXNAT (timeout); + + if (NILP (dx)) + dx = make_fixnum (5); + else + CHECK_FIXNUM (dx); + + if (NILP (dy)) + dy = make_fixnum (-10); + else + CHECK_FIXNUM (dy); + + if (haiku_use_system_tooltips) + { + int root_x, root_y; + CHECK_STRING (string); + if (STRING_MULTIBYTE (string)) + string = ENCODE_UTF_8 (string); + + if (NILP (frame)) + frame = selected_frame; + + struct frame *f = decode_window_system_frame (frame); + block_input (); + + char *str = xstrdup (SSDATA (string)); + int height = be_plain_font_height (); + int width; + char *tok = strtok (str, "\n"); + width = be_string_width_with_plain_font (tok); + + while ((tok = strtok (NULL, "\n"))) + { + height = be_plain_font_height (); + int w = be_string_width_with_plain_font (tok); + if (w > width) + w = width; + } + free (str); + + height += 16; /* Default margin. */ + width += 16; /* Ditto. Unfortunately there isn't a more + reliable way to get it. */ + compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y); + BView_convert_from_screen (FRAME_HAIKU_VIEW (f), &root_x, &root_y); + BView_set_and_show_sticky_tooltip (FRAME_HAIKU_VIEW (f), SSDATA (string), + root_x, root_y); + unblock_input (); + goto start_timer; + } + + if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) + { + if (FRAME_VISIBLE_P (XFRAME (tip_frame)) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (string, tip_last_string)) + && !NILP (Fequal (parms, tip_last_parms))) + { + /* Only DX and DY have changed. */ + tip_f = XFRAME (tip_frame); + if (!NILP (tip_timer)) + { + Lisp_Object timer = tip_timer; + + tip_timer = Qnil; + call1 (Qcancel_timer, timer); + } + + block_input (); + compute_tip_xy (tip_f, parms, dx, dy, FRAME_PIXEL_WIDTH (tip_f), + FRAME_PIXEL_HEIGHT (tip_f), &root_x, &root_y); + haiku_set_offset (tip_f, root_x, root_y, 1); + haiku_visualize_frame (tip_f); + unblock_input (); + + goto start_timer; + } + else if (tooltip_reuse_hidden_frame && EQ (frame, tip_last_frame)) + { + bool delete = false; + Lisp_Object tail, elt, parm, last; + + /* Check if every parameter in PARMS has the same value in + tip_last_parms. This may destruct tip_last_parms + which, however, will be recreated below. */ + for (tail = parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + /* The left, top, right and bottom parameters are handled + by compute_tip_xy so they can be ignored here. */ + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) + && !EQ (parm, Qright) && !EQ (parm, Qbottom)) + { + last = Fassq (parm, tip_last_parms); + if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + else + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); + } + else + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); + } + + /* Now check if there's a parameter left in tip_last_parms with a + non-nil value. */ + for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) + && !EQ (parm, Qbottom) && !NILP (Fcdr (elt))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + } + + haiku_hide_tip (delete); + } + else + haiku_hide_tip (true); + } + else + haiku_hide_tip (true); + + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; + + /* Block input until the tip has been fully drawn, to avoid crashes + when drawing tips in menus. */ + block_input (); + + if (NILP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame))) + { + /* Add default values to frame parameters. */ + if (NILP (Fassq (Qname, parms))) + parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); + if (NILP (Fassq (Qinternal_border_width, parms))) + parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)), parms); + if (NILP (Fassq (Qborder_width, parms))) + parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms); + if (NILP (Fassq (Qborder_color, parms))) + parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), + parms); + if (NILP (Fassq (Qbackground_color, parms))) + parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), + parms); + + /* Create a frame for the tooltip and record it in the global + variable tip_frame. */ + + if (NILP (tip_frame = haiku_create_frame (parms, 1))) + { + /* Creating the tip frame failed. */ + unblock_input (); + return unbind_to (count, Qnil); + } + } + + tip_f = XFRAME (tip_frame); + window = FRAME_ROOT_WINDOW (tip_f); + tip_buf = Fget_buffer_create (tip, Qnil); + /* We will mark the tip window a "pseudo-window" below, and such + windows cannot have display margins. */ + bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); + bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); + set_window_buffer (window, tip_buf, false, false); + w = XWINDOW (window); + w->pseudo_window_p = true; + /* Try to avoid that `other-window' select us (Bug#47207). */ + Fset_window_parameter (window, Qno_other_window, Qt); + + /* Set up the frame's root window. Note: The following code does not + try to size the window or its frame correctly. Its only purpose is + to make the subsequent text size calculations work. The right + sizes should get installed when the toolkit gets back to us. */ + w->left_col = 0; + w->top_line = 0; + w->pixel_left = 0; + w->pixel_top = 0; + + if (CONSP (Vx_max_tooltip_size) + && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX) + && RANGED_FIXNUMP (1, XCDR (Vx_max_tooltip_size), INT_MAX)) + { + w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size)); + w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size)); + } + else + { + w->total_cols = 80; + w->total_lines = 40; + } + + w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (tip_f); + w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (tip_f); + FRAME_TOTAL_COLS (tip_f) = WINDOW_TOTAL_COLS (w); + adjust_frame_glyphs (tip_f); + + /* Insert STRING into the root window's buffer and fit the frame to + the buffer. */ + count_1 = SPECPDL_INDEX (); + old_buffer = current_buffer; + set_buffer_internal_1 (XBUFFER (w->contents)); + bset_truncate_lines (current_buffer, Qnil); + specbind (Qinhibit_read_only, Qt); + specbind (Qinhibit_modification_hooks, Qt); + specbind (Qinhibit_point_motion_hooks, Qt); + Ferase_buffer (); + Finsert (1, &string); + clear_glyph_matrix (w->desired_matrix); + clear_glyph_matrix (w->current_matrix); + SET_TEXT_POS (pos, BEGV, BEGV_BYTE); + try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); + /* Calculate size of tooltip window. */ + size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil, + make_fixnum (w->pixel_height), Qnil); + /* Add the frame's internal border to calculated size. */ + width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + height = XFIXNUM (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + /* Calculate position of tooltip frame. */ + compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y); + BWindow_resize (FRAME_HAIKU_WINDOW (tip_f), width, height); + haiku_set_offset (tip_f, root_x, root_y, 1); + BWindow_set_tooltip_decoration (FRAME_HAIKU_WINDOW (tip_f)); + BView_set_view_cursor (FRAME_HAIKU_VIEW (tip_f), + FRAME_OUTPUT_DATA (XFRAME (frame))->current_cursor); + SET_FRAME_VISIBLE (tip_f, 1); + BWindow_set_visible (FRAME_HAIKU_WINDOW (tip_f), 1); + + w->must_be_updated_p = true; + flush_frame (tip_f); + update_single_window (w); + set_buffer_internal_1 (old_buffer); + unbind_to (count_1, Qnil); + unblock_input (); + windows_or_buffers_changed = old_windows_or_buffers_changed; + + start_timer: + /* Let the tip disappear after timeout seconds. */ + tip_timer = call3 (intern ("run-at-time"), timeout, Qnil, + intern ("x-hide-tip")); + + return unbind_to (count, Qnil); +} + +DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, + doc: /* SKIP: real doc in xfns.c. */) + (void) +{ + return haiku_hide_tip (!tooltip_reuse_hidden_frame); +} + +DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0, + doc: /* SKIP: real doc in xfns.c. */ + attributes: noreturn) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + error ("Cannot close Haiku displays"); +} + +DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, + doc: /* SKIP: real doc in xfns.c. */) + (void) +{ + if (!x_display_list) + return Qnil; + + return list1 (XCAR (x_display_list->name_list_element)); +} + +DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + return build_string ("Haiku, Inc."); +} + +DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + return list3i (5, 1, 1); +} + +DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + return make_fixnum (be_get_display_screens ()); +} + +DEFUN ("haiku-get-version-string", Fhaiku_get_version_string, + Shaiku_get_version_string, 0, 0, 0, + doc: /* Return a string describing the current Haiku version. */) + (void) +{ + char buf[1024]; + + be_get_version_string ((char *) &buf, sizeof buf); + return build_string (buf); +} + +DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + return make_fixnum (be_get_display_color_cells ()); +} + +DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + return make_fixnum (be_get_display_planes ()); +} + +DEFUN ("x-double-buffered-p", Fx_double_buffered_p, Sx_double_buffered_p, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object frame) +{ + struct frame *f = decode_live_frame (frame); + check_window_system (f); + + return EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? Qt : Qnil; +} + +DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + if (FRAMEP (terminal)) + { + CHECK_LIVE_FRAME (terminal); + struct frame *f = decode_window_system_frame (terminal); + + if (FRAME_HAIKU_VIEW (f) && + EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) + return FRAME_PARENT_FRAME (f) ? Qwhen_mapped : Qalways; + else + return Qnot_useful; + } + else + { + check_haiku_display_info (terminal); + return Qnot_useful; + } +} + +DEFUN ("haiku-frame-geometry", Fhaiku_frame_geometry, Shaiku_frame_geometry, 0, 1, 0, + doc: /* Return geometric attributes of FRAME. +FRAME must be a live frame and defaults to the selected one. The return +value is an association list of the attributes listed below. All height +and width values are in pixels. + +`outer-position' is a cons of the outer left and top edges of FRAME + relative to the origin - the position (0, 0) - of FRAME's display. + +`outer-size' is a cons of the outer width and height of FRAME. The + outer size includes the title bar and the external borders as well as + any menu and/or tool bar of frame. + +`external-border-size' is a cons of the horizontal and vertical width of + FRAME's external borders as supplied by the window manager. + +`title-bar-size' is a cons of the width and height of the title bar of + FRAME as supplied by the window manager. If both of them are zero, + FRAME has no title bar. If only the width is zero, Emacs was not + able to retrieve the width information. + +`menu-bar-external', if non-nil, means the menu bar is external (never + included in the inner edges of FRAME). + +`menu-bar-size' is a cons of the width and height of the menu bar of + FRAME. + +`tool-bar-external', if non-nil, means the tool bar is external (never + included in the inner edges of FRAME). + +`tool-bar-position' tells on which side the tool bar on FRAME is and can + be one of `left', `top', `right' or `bottom'. If this is nil, FRAME + has no tool bar. + +`tool-bar-size' is a cons of the width and height of the tool bar of + FRAME. + +`internal-border-width' is the width of the internal border of + FRAME. */) + (Lisp_Object frame) +{ + return frame_geometry (frame, Qnil); +} + +DEFUN ("haiku-frame-edges", Fhaiku_frame_edges, Shaiku_frame_edges, 0, 2, 0, + doc: /* Return edge coordinates of FRAME. +FRAME must be a live frame and defaults to the selected one. The return +value is a list of the form (LEFT, TOP, RIGHT, BOTTOM). All values are +in pixels relative to the origin - the position (0, 0) - of FRAME's +display. + +If optional argument TYPE is the symbol `outer-edges', return the outer +edges of FRAME. The outer edges comprise the decorations of the window +manager (like the title bar or external borders) as well as any external +menu or tool bar of FRAME. If optional argument TYPE is the symbol +`native-edges' or nil, return the native edges of FRAME. The native +edges exclude the decorations of the window manager and any external +menu or tool bar of FRAME. If TYPE is the symbol `inner-edges', return +the inner edges of FRAME. These edges exclude title bar, any borders, +menu bar or tool bar of FRAME. */) + (Lisp_Object frame, Lisp_Object type) +{ + return frame_geometry (frame, ((EQ (type, Qouter_edges) + || EQ (type, Qinner_edges)) + ? type + : Qnative_edges)); +} + +DEFUN ("haiku-read-file-name", Fhaiku_read_file_name, Shaiku_read_file_name, 1, 6, 0, + doc: /* Use a graphical panel to read a file name, using prompt PROMPT. +Optional arg FRAME specifies a frame on which to display the file panel. +If it is nil, the current frame is used instead. +The frame being used will be brought to the front of +the display after the file panel is closed. +Optional arg DIR, if non-nil, supplies a default directory. +Optional arg MUSTMATCH, if non-nil, means the returned file or +directory must exist. +Optional arg DIR_ONLY_P, if non-nil, means choose only directories. +Optional arg SAVE_TEXT, if non-nil, specifies some text to show in the entry field. */) + (Lisp_Object prompt, Lisp_Object frame, + Lisp_Object dir, Lisp_Object mustmatch, + Lisp_Object dir_only_p, Lisp_Object save_text) +{ + ptrdiff_t idx; + if (!x_display_list) + error ("Be windowing not initialized"); + + if (!NILP (dir)) + CHECK_STRING (dir); + + if (!NILP (save_text)) + CHECK_STRING (save_text); + + if (NILP (frame)) + frame = selected_frame; + + CHECK_STRING (prompt); + + CHECK_LIVE_FRAME (frame); + check_window_system (XFRAME (frame)); + + idx = SPECPDL_INDEX (); + record_unwind_protect_void (unwind_popup); + + struct frame *f = XFRAME (frame); + + FRAME_DISPLAY_INFO (f)->focus_event_frame = f; + + ++popup_activated_p; + char *fn = be_popup_file_dialog (!NILP (mustmatch) || !NILP (dir_only_p), + !NILP (dir) ? SSDATA (ENCODE_UTF_8 (dir)) : NULL, + !NILP (mustmatch), !NILP (dir_only_p), + FRAME_HAIKU_WINDOW (f), + !NILP (save_text) ? SSDATA (ENCODE_UTF_8 (save_text)) : NULL, + SSDATA (ENCODE_UTF_8 (prompt)), + block_input, unblock_input); + + unbind_to (idx, Qnil); + + block_input (); + BWindow_activate (FRAME_HAIKU_WINDOW (f)); + unblock_input (); + + if (!fn) + return Qnil; + + Lisp_Object p = build_string_from_utf8 (fn); + free (fn); + return p; +} + +DEFUN ("haiku-put-resource", Fhaiku_put_resource, Shaiku_put_resource, + 2, 2, 0, doc: /* Place STRING by the key RESOURCE in the resource database. +It can later be retrieved with `x-get-resource'. */) + (Lisp_Object resource, Lisp_Object string) +{ + CHECK_STRING (resource); + if (!NILP (string)) + CHECK_STRING (string); + + put_xrm_resource (resource, string); + return Qnil; +} + +DEFUN ("haiku-frame-list-z-order", Fhaiku_frame_list_z_order, + Shaiku_frame_list_z_order, 0, 1, 0, + doc: /* Return list of Emacs' frames, in Z (stacking) order. +If TERMINAL is non-nil and specifies a live frame, return the child +frames of that frame in Z (stacking) order. + +As it is impossible to reliably determine the frame stacking order on +Haiku, the selected frame is always the first element of the returned +list, while the rest are not guaranteed to be in any particular order. + +Frames are listed from topmost (first) to bottommost (last). */) + (Lisp_Object terminal) +{ + Lisp_Object frames = Qnil; + Lisp_Object head, tail; + Lisp_Object sel = Qnil; + + FOR_EACH_FRAME (head, tail) + { + struct frame *f = XFRAME (tail); + if (!FRAME_HAIKU_P (f) || + (FRAMEP (terminal) && + FRAME_LIVE_P (XFRAME (terminal)) && + !EQ (terminal, get_frame_param (f, Qparent_frame)))) + continue; + + if (EQ (tail, selected_frame)) + sel = tail; + else + frames = Fcons (tail, frames); + } + + if (NILP (sel)) + return frames; + return Fcons (sel, frames); +} + +DEFUN ("x-display-save-under", Fx_display_save_under, + Sx_display_save_under, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + if (FRAMEP (terminal)) + { + struct frame *f = decode_window_system_frame (terminal); + return FRAME_HAIKU_VIEW (f) && EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? + Qt : Qnil; + } + + return Qnil; +} + +frame_parm_handler haiku_frame_parm_handlers[] = + { + gui_set_autoraise, + gui_set_autolower, + haiku_set_background_color, + NULL, /* x_set_border_color */ + gui_set_border_width, + haiku_set_cursor_color, + haiku_set_cursor_type, + gui_set_font, + haiku_set_foreground_color, + NULL, /* set icon name */ + NULL, /* set icon type */ + haiku_set_child_frame_border_width, + haiku_set_internal_border_width, + gui_set_right_divider_width, + gui_set_bottom_divider_width, + haiku_set_menu_bar_lines, + NULL, /* set mouse color */ + haiku_explicitly_set_name, + gui_set_scroll_bar_width, + gui_set_scroll_bar_height, + haiku_set_title, + gui_set_unsplittable, + gui_set_vertical_scroll_bars, + gui_set_horizontal_scroll_bars, + gui_set_visibility, + haiku_set_tab_bar_lines, + haiku_set_tool_bar_lines, + NULL, /* set scroll bar fg */ + NULL, /* set scroll bar bkg */ + gui_set_screen_gamma, + gui_set_line_spacing, + gui_set_left_fringe, + gui_set_right_fringe, + NULL, /* x wait for wm */ + gui_set_fullscreen, + gui_set_font_backend, + gui_set_alpha, + NULL, /* set sticky */ + NULL, /* set tool bar pos */ + haiku_set_inhibit_double_buffering, + haiku_set_undecorated, + haiku_set_parent_frame, + NULL, /* set skip taskbar */ + haiku_set_no_focus_on_map, + haiku_set_no_accept_focus, + NULL, /* set z group */ + NULL, /* set override redir */ + gui_set_no_special_glyphs + }; + +void +syms_of_haikufns (void) +{ + DEFSYM (Qfont_parameter, "font-parameter"); + DEFSYM (Qcancel_timer, "cancel-timer"); + DEFSYM (Qassq_delete_all, "assq-delete-all"); + + DEFSYM (Qalways, "always"); + DEFSYM (Qnot_useful, "not-useful"); + DEFSYM (Qwhen_mapped, "when-mapped"); + + defsubr (&Sx_hide_tip); + defsubr (&Sxw_display_color_p); + defsubr (&Sx_display_grayscale_p); + defsubr (&Sx_open_connection); + defsubr (&Sx_create_frame); + defsubr (&Sx_display_pixel_width); + defsubr (&Sx_display_pixel_height); + defsubr (&Sxw_color_values); + defsubr (&Sxw_color_defined_p); + defsubr (&Sx_display_visual_class); + defsubr (&Sx_show_tip); + defsubr (&Sx_display_mm_height); + defsubr (&Sx_display_mm_width); + defsubr (&Sx_close_connection); + defsubr (&Sx_display_list); + defsubr (&Sx_server_vendor); + defsubr (&Sx_server_version); + defsubr (&Sx_display_screens); + defsubr (&Shaiku_get_version_string); + defsubr (&Sx_display_color_cells); + defsubr (&Sx_display_planes); + defsubr (&Shaiku_set_mouse_absolute_pixel_position); + defsubr (&Shaiku_mouse_absolute_pixel_position); + defsubr (&Shaiku_frame_geometry); + defsubr (&Shaiku_frame_edges); + defsubr (&Sx_double_buffered_p); + defsubr (&Sx_display_backing_store); + defsubr (&Shaiku_read_file_name); + defsubr (&Shaiku_put_resource); + defsubr (&Shaiku_frame_list_z_order); + defsubr (&Sx_display_save_under); + + tip_timer = Qnil; + staticpro (&tip_timer); + tip_frame = Qnil; + staticpro (&tip_frame); + tip_last_frame = Qnil; + staticpro (&tip_last_frame); + tip_last_string = Qnil; + staticpro (&tip_last_string); + tip_last_parms = Qnil; + staticpro (&tip_last_parms); + + DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size, + doc: /* SKIP: real doc in xfns.c. */); + Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40)); + + DEFVAR_BOOL ("haiku-use-system-tooltips", haiku_use_system_tooltips, + doc: /* When non-nil, Emacs will display tooltips using the App Kit. +This can avoid a great deal of consing that does not play +well with the Haiku memory allocator, but comes with the +disadvantage of not being able to use special display properties +within tooltips. */); + haiku_use_system_tooltips = 1; + +#ifdef USE_BE_CAIRO + DEFVAR_LISP ("cairo-version-string", Vcairo_version_string, + doc: /* Version info for cairo. */); + { + char cairo_version[sizeof ".." + 3 * INT_STRLEN_BOUND (int)]; + int len = sprintf (cairo_version, "%d.%d.%d", + CAIRO_VERSION_MAJOR, CAIRO_VERSION_MINOR, + CAIRO_VERSION_MICRO); + Vcairo_version_string = make_pure_string (cairo_version, len, len, false); + } +#endif + + return; +} diff --git a/src/haikufont.c b/src/haikufont.c new file mode 100644 index 00000000000..811fa62a848 --- /dev/null +++ b/src/haikufont.c @@ -0,0 +1,1072 @@ +/* Font support for Haiku windowing + +Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "dispextern.h" +#include "composite.h" +#include "blockinput.h" +#include "charset.h" +#include "frame.h" +#include "window.h" +#include "fontset.h" +#include "haikuterm.h" +#include "character.h" +#include "font.h" +#include "termchar.h" +#include "pdumper.h" +#include "haiku_support.h" + +#include +#include + +static Lisp_Object font_cache; + +#define METRICS_NCOLS_PER_ROW (128) + +enum metrics_status + { + METRICS_INVALID = -1, /* metrics entry is invalid */ + }; + +#define METRICS_STATUS(metrics) ((metrics)->ascent + (metrics)->descent) +#define METRICS_SET_STATUS(metrics, status) \ + ((metrics)->ascent = 0, (metrics)->descent = (status)) + +static struct +{ + /* registry name */ + const char *name; + /* characters to distinguish the charset from the others */ + int uniquifier[6]; + /* additional constraint by language */ + const char *lang; +} em_charset_table[] = + { { "iso8859-1", { 0x00A0, 0x00A1, 0x00B4, 0x00BC, 0x00D0 } }, + { "iso8859-2", { 0x00A0, 0x010E }}, + { "iso8859-3", { 0x00A0, 0x0108 }}, + { "iso8859-4", { 0x00A0, 0x00AF, 0x0128, 0x0156, 0x02C7 }}, + { "iso8859-5", { 0x00A0, 0x0401 }}, + { "iso8859-6", { 0x00A0, 0x060C }}, + { "iso8859-7", { 0x00A0, 0x0384 }}, + { "iso8859-8", { 0x00A0, 0x05D0 }}, + { "iso8859-9", { 0x00A0, 0x00A1, 0x00BC, 0x011E }}, + { "iso8859-10", { 0x00A0, 0x00D0, 0x0128, 0x2015 }}, + { "iso8859-11", { 0x00A0, 0x0E01 }}, + { "iso8859-13", { 0x00A0, 0x201C }}, + { "iso8859-14", { 0x00A0, 0x0174 }}, + { "iso8859-15", { 0x00A0, 0x00A1, 0x00D0, 0x0152 }}, + { "iso8859-16", { 0x00A0, 0x0218}}, + { "gb2312.1980-0", { 0x4E13 }, "zh-cn"}, + { "big5-0", { 0x9C21 }, "zh-tw" }, + { "jisx0208.1983-0", { 0x4E55 }, "ja"}, + { "ksc5601.1985-0", { 0xAC00 }, "ko"}, + { "cns11643.1992-1", { 0xFE32 }, "zh-tw"}, + { "cns11643.1992-2", { 0x4E33, 0x7934 }}, + { "cns11643.1992-3", { 0x201A9 }}, + { "cns11643.1992-4", { 0x20057 }}, + { "cns11643.1992-5", { 0x20000 }}, + { "cns11643.1992-6", { 0x20003 }}, + { "cns11643.1992-7", { 0x20055 }}, + { "gbk-0", { 0x4E06 }, "zh-cn"}, + { "jisx0212.1990-0", { 0x4E44 }}, + { "jisx0213.2000-1", { 0xFA10 }, "ja"}, + { "jisx0213.2000-2", { 0xFA49 }}, + { "jisx0213.2004-1", { 0x20B9F }}, + { "viscii1.1-1", { 0x1EA0, 0x1EAE, 0x1ED2 }, "vi"}, + { "tis620.2529-1", { 0x0E01 }, "th"}, + { "microsoft-cp1251", { 0x0401, 0x0490 }, "ru"}, + { "koi8-r", { 0x0401, 0x2219 }, "ru"}, + { "mulelao-1", { 0x0E81 }, "lo"}, + { "unicode-sip", { 0x20000 }}, + { "mulearabic-0", { 0x628 }}, + { "mulearabic-1", { 0x628 }}, + { "mulearabic-2", { 0x628 }}, + { NULL } + }; + +static void +haikufont_apply_registry (struct haiku_font_pattern *pattern, + Lisp_Object registry) +{ + char *str = SSDATA (SYMBOL_NAME (registry)); + USE_SAFE_ALLOCA; + char *re = SAFE_ALLOCA (SBYTES (SYMBOL_NAME (registry)) * 2 + 1); + int i, j; + + for (i = j = 0; i < SBYTES (SYMBOL_NAME (registry)); i++, j++) + { + if (str[i] == '.') + re[j++] = '\\'; + else if (str[i] == '*') + re[j++] = '.'; + re[j] = str[i]; + if (re[j] == '?') + re[j] = '.'; + } + re[j] = '\0'; + AUTO_STRING_WITH_LEN (regexp, re, j); + for (i = 0; em_charset_table[i].name; i++) + if (fast_c_string_match_ignore_case + (regexp, em_charset_table[i].name, + strlen (em_charset_table[i].name)) >= 0) + break; + SAFE_FREE (); + if (!em_charset_table[i].name) + return; + int *uniquifier = em_charset_table[i].uniquifier; + int l; + + for (l = 0; uniquifier[l]; ++l); + + uint32_t *a = xmalloc (l * sizeof *a); + for (l = 0; uniquifier[l]; ++l) + a[l] = uniquifier[l]; + + if (pattern->specified & FSPEC_WANTED) + { + int old_l = l; + l += pattern->want_chars_len; + a = xrealloc (a, l * sizeof *a); + memcpy (&a[old_l], pattern->wanted_chars, (l - old_l) * sizeof *a); + xfree (pattern->wanted_chars); + } + pattern->specified |= FSPEC_WANTED; + pattern->want_chars_len = l; + pattern->wanted_chars = a; + + if (em_charset_table[i].lang) + { + if (!strncmp (em_charset_table[i].lang, "zh", 2)) + { + pattern->specified |= FSPEC_LANGUAGE; + pattern->language = LANGUAGE_CN; + } + else if (!strncmp (em_charset_table[i].lang, "ko", 2)) + { + pattern->specified |= FSPEC_LANGUAGE; + pattern->language = LANGUAGE_KO; + } + else if (!strncmp (em_charset_table[i].lang, "ja", 2)) + { + pattern->specified |= FSPEC_LANGUAGE; + pattern->language = LANGUAGE_JP; + } + } + + return; +} + +static Lisp_Object +haikufont_get_fallback_entity (void) +{ + Lisp_Object ent = font_make_entity (); + ASET (ent, FONT_TYPE_INDEX, Qhaiku); + ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku); + ASET (ent, FONT_FAMILY_INDEX, Qnil); + ASET (ent, FONT_ADSTYLE_INDEX, Qnil); + ASET (ent, FONT_REGISTRY_INDEX, Qutf_8); + ASET (ent, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0)); + ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO)); + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnil); + FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnil); + FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnil); + + return ent; +} + +static Lisp_Object +haikufont_get_cache (struct frame *frame) +{ + return font_cache; +} + +static Lisp_Object +haikufont_weight_to_lisp (int weight) +{ + switch (weight) + { + case HAIKU_THIN: + return Qthin; + case HAIKU_ULTRALIGHT: + return Qultra_light; + case HAIKU_EXTRALIGHT: + return Qextra_light; + case HAIKU_LIGHT: + return Qlight; + case HAIKU_SEMI_LIGHT: + return Qsemi_light; + case HAIKU_REGULAR: + return Qnormal; + case HAIKU_SEMI_BOLD: + return Qsemi_bold; + case HAIKU_BOLD: + return Qbold; + case HAIKU_EXTRA_BOLD: + return Qextra_bold; + case HAIKU_ULTRA_BOLD: + return Qultra_bold; + case HAIKU_BOOK: + return Qbook; + case HAIKU_HEAVY: + return Qheavy; + case HAIKU_ULTRA_HEAVY: + return Qultra_heavy; + case HAIKU_BLACK: + return Qblack; + case HAIKU_MEDIUM: + return Qmedium; + } + emacs_abort (); +} + +static int +haikufont_lisp_to_weight (Lisp_Object weight) +{ + if (EQ (weight, Qthin)) + return HAIKU_THIN; + if (EQ (weight, Qultra_light)) + return HAIKU_ULTRALIGHT; + if (EQ (weight, Qextra_light)) + return HAIKU_EXTRALIGHT; + if (EQ (weight, Qlight)) + return HAIKU_LIGHT; + if (EQ (weight, Qsemi_light)) + return HAIKU_SEMI_LIGHT; + if (EQ (weight, Qnormal)) + return HAIKU_REGULAR; + if (EQ (weight, Qsemi_bold)) + return HAIKU_SEMI_BOLD; + if (EQ (weight, Qbold)) + return HAIKU_BOLD; + if (EQ (weight, Qextra_bold)) + return HAIKU_EXTRA_BOLD; + if (EQ (weight, Qultra_bold)) + return HAIKU_ULTRA_BOLD; + if (EQ (weight, Qbook)) + return HAIKU_BOOK; + if (EQ (weight, Qheavy)) + return HAIKU_HEAVY; + if (EQ (weight, Qultra_heavy)) + return HAIKU_ULTRA_HEAVY; + if (EQ (weight, Qblack)) + return HAIKU_BLACK; + if (EQ (weight, Qmedium)) + return HAIKU_MEDIUM; + + emacs_abort (); +} + +static Lisp_Object +haikufont_slant_to_lisp (enum haiku_font_slant slant) +{ + switch (slant) + { + case NO_SLANT: + emacs_abort (); + case SLANT_ITALIC: + return Qitalic; + case SLANT_REGULAR: + return Qnormal; + case SLANT_OBLIQUE: + return Qoblique; + } + emacs_abort (); +} + +static enum haiku_font_slant +haikufont_lisp_to_slant (Lisp_Object slant) +{ + if (EQ (slant, Qitalic) || + EQ (slant, Qreverse_italic)) + return SLANT_ITALIC; + if (EQ (slant, Qoblique) || + EQ (slant, Qreverse_oblique)) + return SLANT_OBLIQUE; + if (EQ (slant, Qnormal)) + return SLANT_REGULAR; + emacs_abort (); +} + +static Lisp_Object +haikufont_width_to_lisp (enum haiku_font_width width) +{ + switch (width) + { + case NO_WIDTH: + emacs_abort (); + case ULTRA_CONDENSED: + return Qultra_condensed; + case EXTRA_CONDENSED: + return Qextra_condensed; + case CONDENSED: + return Qcondensed; + case SEMI_CONDENSED: + return Qsemi_condensed; + case NORMAL_WIDTH: + return Qnormal; + case SEMI_EXPANDED: + return Qsemi_expanded; + case EXPANDED: + return Qexpanded; + case EXTRA_EXPANDED: + return Qextra_expanded; + case ULTRA_EXPANDED: + return Qultra_expanded; + } + + emacs_abort (); +} + +static enum haiku_font_width +haikufont_lisp_to_width (Lisp_Object lisp) +{ + if (EQ (lisp, Qultra_condensed)) + return ULTRA_CONDENSED; + if (EQ (lisp, Qextra_condensed)) + return EXTRA_CONDENSED; + if (EQ (lisp, Qcondensed)) + return CONDENSED; + if (EQ (lisp, Qsemi_condensed)) + return SEMI_CONDENSED; + if (EQ (lisp, Qnormal)) + return NORMAL_WIDTH; + if (EQ (lisp, Qexpanded)) + return EXPANDED; + if (EQ (lisp, Qextra_expanded)) + return EXTRA_EXPANDED; + if (EQ (lisp, Qultra_expanded)) + return ULTRA_EXPANDED; + emacs_abort (); +} + +static int +haikufont_maybe_handle_special_family (Lisp_Object family, + struct haiku_font_pattern *ptn) +{ + CHECK_SYMBOL (family); + + if (EQ (family, Qmonospace) || EQ (family, Qfixed) || + EQ (family, Qdefault)) + { + BFont_populate_fixed_family (ptn); + return 1; + } + else if (EQ (family, intern ("Sans Serif"))) + { + BFont_populate_plain_family (ptn); + return 1; + } + return 0; +} + +static Lisp_Object +haikufont_pattern_to_entity (struct haiku_font_pattern *ptn) +{ + Lisp_Object ent = font_make_entity (); + ASET (ent, FONT_TYPE_INDEX, Qhaiku); + ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku); + ASET (ent, FONT_FAMILY_INDEX, Qdefault); + ASET (ent, FONT_ADSTYLE_INDEX, Qnil); + ASET (ent, FONT_REGISTRY_INDEX, Qutf_8); + ASET (ent, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0)); + ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO)); + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnormal); + FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnormal); + FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnormal); + + if (ptn->specified & FSPEC_FAMILY) + ASET (ent, FONT_FAMILY_INDEX, intern (ptn->family)); + else + ASET (ent, FONT_FAMILY_INDEX, Qdefault); + + if (ptn->specified & FSPEC_STYLE) + ASET (ent, FONT_ADSTYLE_INDEX, intern (ptn->style)); + else + { + if (ptn->specified & FSPEC_WEIGHT) + FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, + haikufont_weight_to_lisp (ptn->weight)); + if (ptn->specified & FSPEC_SLANT) + FONT_SET_STYLE (ent, FONT_SLANT_INDEX, + haikufont_slant_to_lisp (ptn->slant)); + if (ptn->specified & FSPEC_WIDTH) + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, + haikufont_width_to_lisp (ptn->width)); + } + + if (ptn->specified & FSPEC_SPACING) + ASET (ent, FONT_SPACING_INDEX, + make_fixnum (ptn->mono_spacing_p ? + FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL)); + return ent; +} + +static void +haikufont_spec_or_entity_to_pattern (Lisp_Object ent, + int list_p, + struct haiku_font_pattern *ptn) +{ + Lisp_Object tem; + ptn->specified = 0; + + tem = AREF (ent, FONT_ADSTYLE_INDEX); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_STYLE; + strncpy ((char *) &ptn->style, + SSDATA (SYMBOL_NAME (tem)), + sizeof ptn->style - 1); + } + + tem = FONT_SLANT_SYMBOLIC (ent); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_SLANT; + ptn->slant = haikufont_lisp_to_slant (tem); + } + + tem = FONT_WEIGHT_SYMBOLIC (ent); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_WEIGHT; + ptn->weight = haikufont_lisp_to_weight (tem); + } + + tem = FONT_WIDTH_SYMBOLIC (ent); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_WIDTH; + ptn->width = haikufont_lisp_to_width (tem); + } + + tem = AREF (ent, FONT_SPACING_INDEX); + if (FIXNUMP (tem)) + { + ptn->specified |= FSPEC_SPACING; + ptn->mono_spacing_p = XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL; + } + + tem = AREF (ent, FONT_FAMILY_INDEX); + if (!NILP (tem) && + (list_p && !haikufont_maybe_handle_special_family (tem, ptn))) + { + ptn->specified |= FSPEC_FAMILY; + strncpy ((char *) &ptn->family, + SSDATA (SYMBOL_NAME (tem)), + sizeof ptn->family - 1); + } + + tem = assq_no_quit (QCscript, AREF (ent, FONT_EXTRA_INDEX)); + if (!NILP (tem)) + { + tem = assq_no_quit (XCDR (tem), Vscript_representative_chars); + + if (CONSP (tem) && VECTORP (XCDR (tem))) + { + tem = XCDR (tem); + + int count = 0; + + for (int j = 0; j < ASIZE (tem); ++j) + if (TYPE_RANGED_FIXNUMP (uint32_t, AREF (tem, j))) + ++count; + + if (count) + { + ptn->specified |= FSPEC_NEED_ONE_OF; + ptn->need_one_of_len = count; + ptn->need_one_of = xmalloc (count * sizeof *ptn->need_one_of); + count = 0; + for (int j = 0; j < ASIZE (tem); ++j) + if (TYPE_RANGED_FIXNUMP (uint32_t, AREF (tem, j))) + { + ptn->need_one_of[j] = XFIXNAT (AREF (tem, j)); + ++count; + } + } + } + else if (CONSP (tem) && CONSP (XCDR (tem))) + { + int count = 0; + + for (Lisp_Object it = XCDR (tem); CONSP (it); it = XCDR (it)) + if (TYPE_RANGED_FIXNUMP (uint32_t, XCAR (it))) + ++count; + + if (count) + { + ptn->specified |= FSPEC_WANTED; + ptn->want_chars_len = count; + ptn->wanted_chars = xmalloc (count * sizeof *ptn->wanted_chars); + count = 0; + + for (tem = XCDR (tem); CONSP (tem); tem = XCDR (tem)) + if (TYPE_RANGED_FIXNUMP (uint32_t, XCAR (tem))) + { + ptn->wanted_chars[count] = XFIXNAT (XCAR (tem)); + ++count; + } + } + } + } + + tem = assq_no_quit (QClang, AREF (ent, FONT_EXTRA_INDEX)); + if (CONSP (tem)) + { + tem = XCDR (tem); + if (EQ (tem, Qzh)) + { + ptn->specified |= FSPEC_LANGUAGE; + ptn->language = LANGUAGE_CN; + } + else if (EQ (tem, Qko)) + { + ptn->specified |= FSPEC_LANGUAGE; + ptn->language = LANGUAGE_KO; + } + else if (EQ (tem, Qjp)) + { + ptn->specified |= FSPEC_LANGUAGE; + ptn->language = LANGUAGE_JP; + } + } + + tem = AREF (ent, FONT_REGISTRY_INDEX); + if (SYMBOLP (tem)) + haikufont_apply_registry (ptn, tem); +} + +static void +haikufont_done_with_query_pattern (struct haiku_font_pattern *ptn) +{ + if (ptn->specified & FSPEC_WANTED) + xfree (ptn->wanted_chars); + + if (ptn->specified & FSPEC_NEED_ONE_OF) + xfree (ptn->need_one_of); +} + +static Lisp_Object +haikufont_match (struct frame *f, Lisp_Object font_spec) +{ + block_input (); + Lisp_Object tem = Qnil; + struct haiku_font_pattern ptn; + haikufont_spec_or_entity_to_pattern (font_spec, 0, &ptn); + ptn.specified &= ~FSPEC_FAMILY; + struct haiku_font_pattern *found = BFont_find (&ptn); + haikufont_done_with_query_pattern (&ptn); + if (found) + { + tem = haikufont_pattern_to_entity (found); + haiku_font_pattern_free (found); + } + unblock_input (); + return !NILP (tem) ? tem : haikufont_get_fallback_entity (); +} + +static Lisp_Object +haikufont_list (struct frame *f, Lisp_Object font_spec) +{ + block_input (); + Lisp_Object lst = Qnil; + + /* Returning irrelevant results on receiving an OTF form will cause + fontset.c to loop over and over, making displaying some + characters very slow. */ + Lisp_Object tem = assq_no_quit (QCotf, AREF (font_spec, FONT_EXTRA_INDEX)); + if (CONSP (tem) && !NILP (XCDR (tem))) + { + unblock_input (); + return Qnil; + } + + struct haiku_font_pattern ptn; + haikufont_spec_or_entity_to_pattern (font_spec, 1, &ptn); + struct haiku_font_pattern *found = BFont_find (&ptn); + haikufont_done_with_query_pattern (&ptn); + if (found) + { + for (struct haiku_font_pattern *pt = found; + pt; pt = pt->next) + lst = Fcons (haikufont_pattern_to_entity (pt), lst); + haiku_font_pattern_free (found); + } + unblock_input (); + return lst; +} + +static void +haiku_bulk_encode (struct haikufont_info *font_info, int block) +{ + unsigned short *unichars = xmalloc (0x101 * sizeof (*unichars)); + unsigned int i, idx; + + block_input (); + + font_info->glyphs[block] = unichars; + if (!unichars) + emacs_abort (); + + for (idx = block << 8, i = 0; i < 0x100; idx++, i++) + unichars[i] = idx; + unichars[0x100] = 0; + + + /* If the font contains the entire block, just store it. */ + if (!BFont_have_char_block (font_info->be_font, + unichars[0], unichars[0xff])) + { + for (int i = 0; i < 0x100; ++i) + if (!BFont_have_char_p (font_info->be_font, unichars[i])) + unichars[i] = 0xFFFF; + } + + unblock_input (); +} + +static unsigned int +haikufont_encode_char (struct font *font, int c) +{ + struct haikufont_info *font_info = (struct haikufont_info *) font; + unsigned char high = (c & 0xff00) >> 8, low = c & 0x00ff; + unsigned short g; + + if (c > 0xFFFF) + return FONT_INVALID_CODE; + + if (!font_info->glyphs[high]) + haiku_bulk_encode (font_info, high); + g = font_info->glyphs[high][low]; + return g == 0xFFFF ? FONT_INVALID_CODE : g; +} + +static Lisp_Object +haikufont_open (struct frame *f, Lisp_Object font_entity, int x) +{ + struct haikufont_info *font_info; + struct haiku_font_pattern ptn; + struct font *font; + void *be_font; + Lisp_Object font_object; + Lisp_Object tem; + + block_input (); + if (x <= 0) + { + /* Get pixel size from frame instead. */ + tem = get_frame_param (f, Qfontsize); + x = NILP (tem) ? 0 : XFIXNAT (tem); + } + + haikufont_spec_or_entity_to_pattern (font_entity, 1, &ptn); + + if (BFont_open_pattern (&ptn, &be_font, x)) + { + haikufont_done_with_query_pattern (&ptn); + unblock_input (); + return Qnil; + } + + haikufont_done_with_query_pattern (&ptn); + + font_object = font_make_object (VECSIZE (struct haikufont_info), + font_entity, x); + + ASET (font_object, FONT_TYPE_INDEX, Qhaiku); + font_info = (struct haikufont_info *) XFONT_OBJECT (font_object); + font = (struct font *) font_info; + + if (!font) + { + unblock_input (); + return Qnil; + } + + font_info->be_font = be_font; + font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs); + + font->pixel_size = 0; + font->driver = &haikufont_driver; + font->encoding_charset = -1; + font->repertory_charset = -1; + font->default_ascent = 0; + font->vertical_centering = 0; + font->baseline_offset = 0; + font->relative_compose = 0; + + font_info->metrics = NULL; + font_info->metrics_nrows = 0; + + int px_size, min_width, max_width, + avg_width, height, space_width, ascent, + descent, underline_pos, underline_thickness; + + BFont_dat (be_font, &px_size, &min_width, + &max_width, &avg_width, &height, + &space_width, &ascent, &descent, + &underline_pos, &underline_thickness); + + font->pixel_size = px_size; + font->min_width = min_width; + font->max_width = max_width; + font->average_width = avg_width; + font->height = height; + font->space_width = space_width; + font->ascent = ascent; + font->descent = descent; + font->default_ascent = ascent; + font->underline_position = underline_pos; + font->underline_thickness = underline_thickness; + + font->vertical_centering = 0; + font->baseline_offset = 0; + font->relative_compose = 0; + + font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil); + + unblock_input (); + return font_object; +} + +static void +haikufont_close (struct font *font) +{ + if (font_data_structures_may_be_ill_formed ()) + return; + struct haikufont_info *info = (struct haikufont_info *) font; + + block_input (); + if (info && info->be_font) + BFont_close (info->be_font); + + for (int i = 0; i < info->metrics_nrows; i++) + if (info->metrics[i]) + xfree (info->metrics[i]); + if (info->metrics) + xfree (info->metrics); + for (int i = 0; i < 0x100; ++i) + if (info->glyphs[i]) + xfree (info->glyphs[i]); + xfree (info->glyphs); + unblock_input (); +} + +static void +haikufont_prepare_face (struct frame *f, struct face *face) +{ + +} + +static void +haikufont_glyph_extents (struct font *font, unsigned code, + struct font_metrics *metrics) +{ + struct haikufont_info *info = (struct haikufont_info *) font; + + struct font_metrics *cache; + int row, col; + + row = code / METRICS_NCOLS_PER_ROW; + col = code % METRICS_NCOLS_PER_ROW; + if (row >= info->metrics_nrows) + { + info->metrics = + xrealloc (info->metrics, + sizeof (struct font_metrics *) * (row + 1)); + memset (info->metrics + info->metrics_nrows, 0, + (sizeof (struct font_metrics *) + * (row + 1 - info->metrics_nrows))); + info->metrics_nrows = row + 1; + } + + if (info->metrics[row] == NULL) + { + struct font_metrics *new; + int i; + + new = xmalloc (sizeof (struct font_metrics) * METRICS_NCOLS_PER_ROW); + for (i = 0; i < METRICS_NCOLS_PER_ROW; i++) + METRICS_SET_STATUS (new + i, METRICS_INVALID); + info->metrics[row] = new; + } + cache = info->metrics[row] + col; + + if (METRICS_STATUS (cache) == METRICS_INVALID) + { + unsigned char utf8[MAX_MULTIBYTE_LENGTH]; + memset (utf8, 0, MAX_MULTIBYTE_LENGTH); + CHAR_STRING (code, utf8); + int advance, lb, rb; + BFont_char_bounds (info->be_font, (const char *) utf8, &advance, &lb, &rb); + + cache->lbearing = lb; + cache->rbearing = rb; + cache->width = advance; + cache->ascent = font->ascent; + cache->descent = font->descent; + } + + if (metrics) + *metrics = *cache; +} + +static void +haikufont_text_extents (struct font *font, const unsigned int *code, + int nglyphs, struct font_metrics *metrics) +{ + int totalwidth = 0; + memset (metrics, 0, sizeof (struct font_metrics)); + + block_input (); + for (int i = 0; i < nglyphs; i++) + { + struct font_metrics m; + haikufont_glyph_extents (font, code[i], &m); + if (metrics) + { + if (totalwidth + m.lbearing < metrics->lbearing) + metrics->lbearing = totalwidth + m.lbearing; + if (totalwidth + m.rbearing > metrics->rbearing) + metrics->rbearing = totalwidth + m.rbearing; + if (m.ascent > metrics->ascent) + metrics->ascent = m.ascent; + if (m.descent > metrics->descent) + metrics->descent = m.descent; + } + totalwidth += m.width; + } + + unblock_input (); + + if (metrics) + metrics->width = totalwidth; +} + +static Lisp_Object +haikufont_shape (Lisp_Object lgstring, Lisp_Object direction) +{ + struct haikufont_info *font = + (struct haikufont_info *) CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring)); + int *advance, *lb, *rb; + ptrdiff_t glyph_len, len, i, b_len; + Lisp_Object tem; + char *b; + uint32_t *mb_buf; + + glyph_len = LGSTRING_GLYPH_LEN (lgstring); + for (i = 0; i < glyph_len; ++i) + { + tem = LGSTRING_GLYPH (lgstring, i); + + if (NILP (tem)) + break; + } + + len = i; + + if (INT_MAX / 2 < len) + memory_full (SIZE_MAX); + + block_input (); + + b_len = 0; + b = xmalloc (b_len); + mb_buf = alloca (len * sizeof *mb_buf); + + for (i = b_len; i < len; ++i) + { + uint32_t c = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i)); + mb_buf[i] = c; + unsigned char mb[MAX_MULTIBYTE_LENGTH]; + int slen = CHAR_STRING (c, mb); + + b = xrealloc (b, b_len = (b_len + slen)); + if (len == 1) + b[b_len - slen] = mb[0]; + else + memcpy (b + b_len - slen, mb, slen); + } + + advance = alloca (len * sizeof *advance); + lb = alloca (len * sizeof *lb); + rb = alloca (len * sizeof *rb); + + eassert (font->be_font); + BFont_nchar_bounds (font->be_font, b, advance, lb, rb, len); + xfree (b); + + for (i = 0; i < len; ++i) + { + tem = LGSTRING_GLYPH (lgstring, i); + if (NILP (tem)) + { + tem = LGLYPH_NEW (); + LGSTRING_SET_GLYPH (lgstring, i, tem); + } + + LGLYPH_SET_FROM (tem, i); + LGLYPH_SET_TO (tem, i); + LGLYPH_SET_CHAR (tem, mb_buf[i]); + LGLYPH_SET_CODE (tem, mb_buf[i]); + + LGLYPH_SET_WIDTH (tem, advance[i]); + LGLYPH_SET_LBEARING (tem, lb[i]); + LGLYPH_SET_RBEARING (tem, rb[i]); + LGLYPH_SET_ASCENT (tem, font->font.ascent); + LGLYPH_SET_DESCENT (tem, font->font.descent); + } + + unblock_input (); + + return make_fixnum (len); +} + +static int +haikufont_draw (struct glyph_string *s, int from, int to, + int x, int y, bool with_background) +{ + struct frame *f = s->f; + struct face *face = s->face; + struct font_info *info = (struct font_info *) s->font; + unsigned char mb[MAX_MULTIBYTE_LENGTH]; + void *view = FRAME_HAIKU_VIEW (f); + + block_input (); + prepare_face_for_display (s->f, face); + + BView_draw_lock (view); + BView_StartClip (view); + if (with_background) + { + int height = FONT_HEIGHT (s->font), ascent = FONT_BASE (s->font); + + /* Font's global height and ascent values might be + preposterously large for some fonts. We fix here the case + when those fonts are used for display of glyphless + characters, because drawing background with font dimensions + in those cases makes the display illegible. There's only one + more call to the draw method with with_background set to + true, and that's in x_draw_glyph_string_foreground, when + drawing the cursor, where we have no such heuristics + available. FIXME. */ + if (s->first_glyph->type == GLYPHLESS_GLYPH + && (s->first_glyph->u.glyphless.method == GLYPHLESS_DISPLAY_HEX_CODE + || s->first_glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM)) + height = ascent = + s->first_glyph->slice.glyphless.lower_yoff + - s->first_glyph->slice.glyphless.upper_yoff; + + BView_SetHighColor (view, s->hl == DRAW_CURSOR ? + FRAME_CURSOR_COLOR (s->f).pixel : face->background); + + BView_FillRectangle (view, x, y - ascent, s->width, height); + s->background_filled_p = 1; + } + + if (s->left_overhang && s->clip_head && !s->for_overlaps) + { + /* XXX: Why is this neccessary? */ + BView_ClipToRect (view, s->clip_head->x, 0, + FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + } + + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else + BView_SetHighColor (view, face->foreground); + + BView_MovePenTo (view, x, y); + BView_SetFont (view, ((struct haikufont_info *) info)->be_font); + + if (from == to) + { + int len = CHAR_STRING (s->char2b[from], mb); + BView_DrawString (view, (char *) mb, len); + } + else + { + ptrdiff_t b_len = 0; + char *b = xmalloc (b_len); + + for (int idx = from; idx < to; ++idx) + { + int len = CHAR_STRING (s->char2b[idx], mb); + b = xrealloc (b, b_len = (b_len + len)); + if (len == 1) + b[b_len - len] = mb[0]; + else + memcpy (b + b_len - len, mb, len); + } + + BView_DrawString (view, b, b_len); + xfree (b); + } + BView_EndClip (view); + BView_draw_unlock (view); + unblock_input (); + return 1; +} + +struct font_driver const haikufont_driver = + { + .type = LISPSYM_INITIALLY (Qhaiku), + .case_sensitive = true, + .get_cache = haikufont_get_cache, + .list = haikufont_list, + .match = haikufont_match, + .draw = haikufont_draw, + .open_font = haikufont_open, + .close_font = haikufont_close, + .prepare_face = haikufont_prepare_face, + .encode_char = haikufont_encode_char, + .text_extents = haikufont_text_extents, + .shape = haikufont_shape + }; + +void +syms_of_haikufont (void) +{ + DEFSYM (Qfontsize, "fontsize"); + DEFSYM (Qfixed, "fixed"); + DEFSYM (Qplain, "plain"); + DEFSYM (Qultra_light, "ultra-light"); + DEFSYM (Qthin, "thin"); + DEFSYM (Qreverse_italic, "reverse-italic"); + DEFSYM (Qreverse_oblique, "reverse-oblique"); + DEFSYM (Qmonospace, "monospace"); + DEFSYM (Qultra_condensed, "ultra-condensed"); + DEFSYM (Qextra_condensed, "extra-condensed"); + DEFSYM (Qcondensed, "condensed"); + DEFSYM (Qsemi_condensed, "semi-condensed"); + DEFSYM (Qsemi_expanded, "semi-expanded"); + DEFSYM (Qexpanded, "expanded"); + DEFSYM (Qextra_expanded, "extra-expanded"); + DEFSYM (Qultra_expanded, "ultra-expanded"); + DEFSYM (Qzh, "zh"); + DEFSYM (Qko, "ko"); + DEFSYM (Qjp, "jp"); + + font_cache = list (Qnil); + staticpro (&font_cache); +} diff --git a/src/haikugui.h b/src/haikugui.h new file mode 100644 index 00000000000..cfc693fb552 --- /dev/null +++ b/src/haikugui.h @@ -0,0 +1,106 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_GUI_H_ +#define _HAIKU_GUI_H_ + +#ifdef _cplusplus +extern "C" +{ +#endif + +typedef struct haiku_char_struct +{ + int rbearing; + int lbearing; + int width; + int ascent; + int descent; +} XCharStruct; + +struct haiku_rect +{ + int x, y; + int width, height; +}; + +typedef void *haiku; + +typedef haiku Emacs_Pixmap; +typedef haiku Emacs_Window; +typedef haiku Emacs_Cursor; +typedef haiku Drawable; + +#define NativeRectangle struct haiku_rect +#define CONVERT_TO_EMACS_RECT(xr, nr) \ + ((xr).x = (nr).x, \ + (xr).y = (nr).y, \ + (xr).width = (nr).width, \ + (xr).height = (nr).height) + +#define CONVERT_FROM_EMACS_RECT(xr, nr) \ + ((nr).x = (xr).x, \ + (nr).y = (xr).y, \ + (nr).width = (xr).width, \ + (nr).height = (xr).height) + +#define STORE_NATIVE_RECT(nr, px, py, pwidth, pheight) \ + ((nr).x = (px), \ + (nr).y = (py), \ + (nr).width = (pwidth), \ + (nr).height = (pheight)) + +#define ForgetGravity 0 +#define NorthWestGravity 1 +#define NorthGravity 2 +#define NorthEastGravity 3 +#define WestGravity 4 +#define CenterGravity 5 +#define EastGravity 6 +#define SouthWestGravity 7 +#define SouthGravity 8 +#define SouthEastGravity 9 +#define StaticGravity 10 + +#define NoValue 0x0000 +#define XValue 0x0001 +#define YValue 0x0002 +#define WidthValue 0x0004 +#define HeightValue 0x0008 +#define AllValues 0x000F +#define XNegative 0x0010 +#define YNegative 0x0020 + +#define USPosition (1L << 0) /* user specified x, y */ +#define USSize (1L << 1) /* user specified width, height */ +#define PPosition (1L << 2) /* program specified position */ +#define PSize (1L << 3) /* program specified size */ +#define PMinSize (1L << 4) /* program specified minimum size */ +#define PMaxSize (1L << 5) /* program specified maximum size */ +#define PResizeInc (1L << 6) /* program specified resize increments */ +#define PAspect (1L << 7) /* program specified min, max aspect ratios */ +#define PBaseSize (1L << 8) /* program specified base for incrementing */ +#define PWinGravity (1L << 9) /* program specified window gravity */ + +typedef haiku Window; +typedef int Display; + +#ifdef _cplusplus +}; +#endif +#endif /* _HAIKU_GUI_H_ */ diff --git a/src/haikuimage.c b/src/haikuimage.c new file mode 100644 index 00000000000..138e5b84e6a --- /dev/null +++ b/src/haikuimage.c @@ -0,0 +1,109 @@ +/* Haiku window system support. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "dispextern.h" +#include "haikuterm.h" +#include "coding.h" + +#include "haiku_support.h" + +bool +haiku_can_use_native_image_api (Lisp_Object type) +{ + const char *mime_type = NULL; + + if (EQ (type, Qnative_image)) + return 1; + +#ifdef HAVE_RSVG + if (EQ (type, Qsvg)) + return 0; +#endif + + if (EQ (type, Qjpeg)) + mime_type = "image/jpeg"; + else if (EQ (type, Qpng)) + mime_type = "image/png"; + else if (EQ (type, Qgif)) + mime_type = "image/gif"; + else if (EQ (type, Qtiff)) + mime_type = "image/tiff"; + else if (EQ (type, Qbmp)) + mime_type = "image/bmp"; + else if (EQ (type, Qsvg)) + mime_type = "image/svg"; + else if (EQ (type, Qpbm)) + mime_type = "image/pbm"; + + if (!mime_type) + return 0; + + return be_can_translate_type_to_bitmap_p (mime_type); +} + +extern int +haiku_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data) +{ + eassert (valid_image_p (img->spec)); + + void *pixmap = NULL; + + if (STRINGP (spec_file)) + { + pixmap = be_translate_bitmap_from_file_name + (SSDATA (ENCODE_UTF_8 (spec_file))); + } + else if (STRINGP (spec_data)) + { + pixmap = be_translate_bitmap_from_memory + (SSDATA (spec_data), SBYTES (spec_data)); + } + + void *conv = NULL; + + if (!pixmap || !BBitmap_convert (pixmap, &conv)) + { + add_to_log ("Unable to load image %s", img->spec); + return 0; + } + + if (conv) + { + BBitmap_free (pixmap); + pixmap = conv; + } + + int left, top, right, bottom, stride, mono_p; + BBitmap_dimensions (pixmap, &left, &top, &right, &bottom, &stride, &mono_p); + + img->width = (1 + right - left); + img->height = (1 + bottom - top); + img->pixmap = pixmap; + + return 1; +} + +void +syms_of_haikuimage (void) +{ + DEFSYM (Qbmp, "bmp"); +} diff --git a/src/haikumenu.c b/src/haikumenu.c new file mode 100644 index 00000000000..698da9d639c --- /dev/null +++ b/src/haikumenu.c @@ -0,0 +1,656 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "frame.h" +#include "keyboard.h" +#include "menu.h" +#include "buffer.h" +#include "blockinput.h" + +#include "haikuterm.h" +#include "haiku_support.h" + +static Lisp_Object *volatile menu_item_selection; + +int popup_activated_p = 0; + +struct submenu_stack_cell +{ + void *parent_menu; + void *pane; +}; + +static void +digest_menu_items (void *first_menu, int start, int menu_items_used, + int mbar_p) +{ + void **menus, **panes; + ssize_t menu_len = (menu_items_used + 1 - start) * sizeof *menus; + ssize_t pane_len = (menu_items_used + 1 - start) * sizeof *panes; + + menus = alloca (menu_len); + panes = alloca (pane_len); + + int i = start, menu_depth = 0; + + memset (menus, 0, menu_len); + memset (panes, 0, pane_len); + + void *menu = first_menu; + + menus[0] = first_menu; + + void *window = NULL; + if (FRAMEP (Vmenu_updating_frame) && + FRAME_LIVE_P (XFRAME (Vmenu_updating_frame)) && + FRAME_HAIKU_P (XFRAME (Vmenu_updating_frame))) + window = FRAME_HAIKU_WINDOW (XFRAME (Vmenu_updating_frame)); + + while (i < menu_items_used) + { + if (NILP (AREF (menu_items, i))) + { + menus[++menu_depth] = menu; + i++; + } + else if (EQ (AREF (menu_items, i), Qlambda)) + { + panes[menu_depth] = NULL; + menu = panes[--menu_depth] ? panes[menu_depth] : menus[menu_depth]; + i++; + } + else if (EQ (AREF (menu_items, i), Qquote)) + i += 1; + else if (EQ (AREF (menu_items, i), Qt)) + { + Lisp_Object pane_name, prefix; + const char *pane_string; + + if (menu_items_n_panes == 1) + { + i += MENU_ITEMS_PANE_LENGTH; + continue; + } + + pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME); + prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX); + + if (STRINGP (pane_name) && STRING_MULTIBYTE (pane_name)) + { + pane_name = ENCODE_UTF_8 (pane_name); + ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name); + } + + pane_string = (NILP (pane_name) + ? "" : SSDATA (pane_name)); + if (!NILP (prefix)) + pane_string++; + + if (strcmp (pane_string, "")) + { + panes[menu_depth] = + menu = BMenu_new_submenu (menus[menu_depth], pane_string, 1); + } + + i += MENU_ITEMS_PANE_LENGTH; + } + else + { + Lisp_Object item_name, enable, descrip, def, selected, help; + item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME); + enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE); + descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY); + def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION); + selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED); + help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP); + + if (STRINGP (item_name) && STRING_MULTIBYTE (item_name)) + { + item_name = ENCODE_UTF_8 (item_name); + ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name); + } + + if (STRINGP (descrip) && STRING_MULTIBYTE (descrip)) + { + descrip = ENCODE_UTF_8 (descrip); + ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip); + } + + if (STRINGP (help) && STRING_MULTIBYTE (help)) + { + help = ENCODE_UTF_8 (help); + ASET (menu_items, i + MENU_ITEMS_ITEM_HELP, help); + } + + if (i + MENU_ITEMS_ITEM_LENGTH < menu_items_used && + NILP (AREF (menu_items, i + MENU_ITEMS_ITEM_LENGTH))) + menu = BMenu_new_submenu (menu, SSDATA (item_name), !NILP (enable)); + else if (NILP (def) && menu_separator_name_p (SSDATA (item_name))) + BMenu_add_separator (menu); + else if (!mbar_p) + BMenu_add_item (menu, SSDATA (item_name), + !NILP (def) ? aref_addr (menu_items, i) : NULL, + !NILP (enable), !NILP (selected), 0, window, + !NILP (descrip) ? SSDATA (descrip) : NULL, + STRINGP (help) ? SSDATA (help) : NULL); + else + BMenu_add_item (menu, SSDATA (item_name), + !NILP (def) ? (void *) (intptr_t) i : NULL, + !NILP (enable), !NILP (selected), 1, window, + !NILP (descrip) ? SSDATA (descrip) : NULL, + STRINGP (help) ? SSDATA (help) : NULL); + + i += MENU_ITEMS_ITEM_LENGTH; + } + } +} + +static Lisp_Object +haiku_dialog_show (struct frame *f, Lisp_Object title, + Lisp_Object header, const char **error_name) +{ + int i, nb_buttons = 0; + + *error_name = NULL; + + if (menu_items_n_panes > 1) + { + *error_name = "Multiple panes in dialog box"; + return Qnil; + } + + Lisp_Object pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME); + i = MENU_ITEMS_PANE_LENGTH; + + if (STRING_MULTIBYTE (pane_name)) + pane_name = ENCODE_UTF_8 (pane_name); + + block_input (); + void *alert = BAlert_new (SSDATA (pane_name), NILP (header) ? HAIKU_INFO_ALERT : + HAIKU_IDEA_ALERT); + + Lisp_Object vals[10]; + + while (i < menu_items_used) + { + Lisp_Object item_name, enable, descrip, value; + item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME); + enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE); + descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY); + value = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE); + + if (NILP (item_name)) + { + BAlert_delete (alert); + *error_name = "Submenu in dialog items"; + unblock_input (); + return Qnil; + } + + if (EQ (item_name, Qquote)) + { + i++; + } + + if (nb_buttons >= 9) + { + BAlert_delete (alert); + *error_name = "Too many dialog items"; + unblock_input (); + return Qnil; + } + + if (STRING_MULTIBYTE (item_name)) + item_name = ENCODE_UTF_8 (item_name); + if (!NILP (descrip) && STRING_MULTIBYTE (descrip)) + descrip = ENCODE_UTF_8 (descrip); + + void *button = BAlert_add_button (alert, SSDATA (item_name)); + + BButton_set_enabled (button, !NILP (enable)); + if (!NILP (descrip)) + BView_set_tooltip (button, SSDATA (descrip)); + + vals[nb_buttons] = value; + ++nb_buttons; + i += MENU_ITEMS_ITEM_LENGTH; + } + + int32_t val = BAlert_go (alert); + unblock_input (); + + if (val < 0) + quit (); + else + return vals[val]; + + return Qnil; +} + +Lisp_Object +haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) +{ + Lisp_Object title; + const char *error_name = NULL; + Lisp_Object selection; + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + + check_window_system (f); + + /* Decode the dialog items from what was specified. */ + title = Fcar (contents); + CHECK_STRING (title); + record_unwind_protect_void (unuse_menu_items); + + if (NILP (Fcar (Fcdr (contents)))) + /* No buttons specified, add an "Ok" button so users can pop down + the dialog. Also, the lesstif/motif version crashes if there are + no buttons. */ + contents = list2 (title, Fcons (build_string ("Ok"), Qt)); + + list_of_panes (list1 (contents)); + + /* Display them in a dialog box. */ + block_input (); + selection = haiku_dialog_show (f, title, header, &error_name); + unblock_input (); + + unbind_to (specpdl_count, Qnil); + discard_menu_items (); + + if (error_name) + error ("%s", error_name); + return selection; +} + +Lisp_Object +haiku_menu_show (struct frame *f, int x, int y, int menuflags, + Lisp_Object title, const char **error_name) +{ + int i = 0, submenu_depth = 0; + void *view = FRAME_HAIKU_VIEW (f); + void *menu; + + Lisp_Object *subprefix_stack = + alloca (menu_items_used * sizeof (Lisp_Object)); + + eassert (FRAME_HAIKU_P (f)); + + *error_name = NULL; + + if (menu_items_used <= MENU_ITEMS_PANE_LENGTH) + { + *error_name = "Empty menu"; + return Qnil; + } + + block_input (); + if (STRINGP (title) && STRING_MULTIBYTE (title)) + title = ENCODE_UTF_8 (title); + + menu = BPopUpMenu_new (STRINGP (title) ? SSDATA (title) : NULL); + if (STRINGP (title)) + { + BMenu_add_title (menu, SSDATA (title)); + BMenu_add_separator (menu); + } + digest_menu_items (menu, 0, menu_items_used, 0); + BView_convert_to_screen (view, &x, &y); + unblock_input (); + + menu_item_selection = BMenu_run (menu, x, y); + + FRAME_DISPLAY_INFO (f)->grabbed = 0; + + if (menu_item_selection) + { + Lisp_Object prefix, entry; + + prefix = entry = Qnil; + i = 0; + while (i < menu_items_used) + { + if (NILP (AREF (menu_items, i))) + { + subprefix_stack[submenu_depth++] = prefix; + prefix = entry; + i++; + } + else if (EQ (AREF (menu_items, i), Qlambda)) + { + prefix = subprefix_stack[--submenu_depth]; + i++; + } + else if (EQ (AREF (menu_items, i), Qt)) + { + prefix + = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX); + i += MENU_ITEMS_PANE_LENGTH; + } + /* Ignore a nil in the item list. + It's meaningful only for dialog boxes. */ + else if (EQ (AREF (menu_items, i), Qquote)) + i += 1; + else + { + entry + = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE); + if (menu_item_selection == aref_addr (menu_items, i)) + { + if (menuflags & MENU_KEYMAPS) + { + int j; + + entry = list1 (entry); + if (!NILP (prefix)) + entry = Fcons (prefix, entry); + for (j = submenu_depth - 1; j >= 0; j--) + if (!NILP (subprefix_stack[j])) + entry = Fcons (subprefix_stack[j], entry); + } + BPopUpMenu_delete (menu); + return entry; + } + i += MENU_ITEMS_ITEM_LENGTH; + } + } + } + else if (!(menuflags & MENU_FOR_CLICK)) + { + BPopUpMenu_delete (menu); + quit (); + } + BPopUpMenu_delete (menu); + return Qnil; +} + +void +free_frame_menubar (struct frame *f) +{ + FRAME_MENU_BAR_LINES (f) = 0; + FRAME_MENU_BAR_HEIGHT (f) = 0; + FRAME_EXTERNAL_MENU_BAR (f) = 0; + + block_input (); + void *mbar = FRAME_HAIKU_MENU_BAR (f); + if (mbar) + BMenuBar_delete (mbar); + if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + --popup_activated_p; + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0; + unblock_input (); + + adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines); +} + +void +initialize_frame_menubar (struct frame *f) +{ + /* This function is called before the first chance to redisplay + the frame. It has to be, so the frame will have the right size. */ + fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); + set_frame_menubar (f, true); +} + +void +set_frame_menubar (struct frame *f, bool deep_p) +{ + void *mbar = FRAME_HAIKU_MENU_BAR (f); + void *view = FRAME_HAIKU_VIEW (f); + + int first_time_p = 0; + + if (!mbar) + { + mbar = FRAME_HAIKU_MENU_BAR (f) = BMenuBar_new (view); + first_time_p = 1; + } + + Lisp_Object items; + struct buffer *prev = current_buffer; + Lisp_Object buffer; + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + int previous_menu_items_used = f->menu_bar_items_used; + Lisp_Object *previous_items + = alloca (previous_menu_items_used * sizeof *previous_items); + + XSETFRAME (Vmenu_updating_frame, f); + + if (!deep_p) + { + FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 0; + items = FRAME_MENU_BAR_ITEMS (f); + Lisp_Object string; + + block_input (); + int count = BMenu_count_items (mbar); + + int i; + for (i = 0; i < ASIZE (items); i += 4) + { + string = AREF (items, i + 1); + + if (!STRINGP (string)) + break; + + if (STRING_MULTIBYTE (string)) + string = ENCODE_UTF_8 (string); + + if (i / 4 < count) + { + void *it = BMenu_item_at (mbar, i / 4); + BMenu_item_set_label (it, SSDATA (string)); + } + else + BMenu_new_menu_bar_submenu (mbar, SSDATA (string)); + } + + if (i / 4 < count) + BMenu_delete_from (mbar, i / 4, count - i / 4 + 1); + unblock_input (); + + f->menu_bar_items_used = 0; + } + else + { + /* If we are making a new widget, its contents are empty, + do always reinitialize them. */ + if (first_time_p) + previous_menu_items_used = 0; + buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents; + specbind (Qinhibit_quit, Qt); + /* Don't let the debugger step into this code + because it is not reentrant. */ + specbind (Qdebug_on_next_call, Qnil); + + record_unwind_save_match_data (); + if (NILP (Voverriding_local_map_menu_flag)) + { + specbind (Qoverriding_terminal_local_map, Qnil); + specbind (Qoverriding_local_map, Qnil); + } + + set_buffer_internal_1 (XBUFFER (buffer)); + + /* Run the Lucid hook. */ + safe_run_hooks (Qactivate_menubar_hook); + + /* If it has changed current-menubar from previous value, + really recompute the menubar from the value. */ + if (! NILP (Vlucid_menu_bar_dirty_flag)) + call0 (Qrecompute_lucid_menubar); + safe_run_hooks (Qmenu_bar_update_hook); + fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); + + items = FRAME_MENU_BAR_ITEMS (f); + + /* Save the frame's previous menu bar contents data. */ + if (previous_menu_items_used) + memcpy (previous_items, xvector_contents (f->menu_bar_vector), + previous_menu_items_used * word_size); + + /* Fill in menu_items with the current menu bar contents. + This can evaluate Lisp code. */ + save_menu_items (); + menu_items = f->menu_bar_vector; + menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0; + init_menu_items (); + int i; + int count = BMenu_count_items (mbar); + int subitems = ASIZE (items) / 4; + + int *submenu_start, *submenu_end, *submenu_n_panes; + Lisp_Object *submenu_names; + + submenu_start = alloca ((subitems + 1) * sizeof *submenu_start); + submenu_end = alloca (subitems * sizeof *submenu_end); + submenu_n_panes = alloca (subitems * sizeof *submenu_n_panes); + submenu_names = alloca (subitems * sizeof (Lisp_Object)); + + for (i = 0; i < subitems; ++i) + { + Lisp_Object key, string, maps; + + key = AREF (items, i * 4); + string = AREF (items, i * 4 + 1); + maps = AREF (items, i * 4 + 2); + + if (NILP (string)) + break; + + if (STRINGP (string) && STRING_MULTIBYTE (string)) + string = ENCODE_UTF_8 (string); + + submenu_start[i] = menu_items_used; + menu_items_n_panes = 0; + parse_single_submenu (key, string, maps); + submenu_n_panes[i] = menu_items_n_panes; + submenu_end[i] = menu_items_used; + submenu_names[i] = string; + } + finish_menu_items (); + submenu_start[i] = -1; + + block_input (); + for (i = 0; submenu_start[i] >= 0; ++i) + { + void *mn = NULL; + if (i < count) + mn = BMenu_item_get_menu (BMenu_item_at (mbar, i)); + if (mn) + BMenu_delete_all (mn); + else + mn = BMenu_new_menu_bar_submenu (mbar, SSDATA (submenu_names[i])); + + menu_items_n_panes = submenu_n_panes[i]; + digest_menu_items (mn, submenu_start[i], submenu_end[i], 1); + } + unblock_input (); + + set_buffer_internal_1 (prev); + + FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 1; + fset_menu_bar_vector (f, menu_items); + f->menu_bar_items_used = menu_items_used; + } + unbind_to (specpdl_count, Qnil); +} + +void +run_menu_bar_help_event (struct frame *f, int mb_idx) +{ + Lisp_Object frame; + Lisp_Object vec; + Lisp_Object help; + + block_input (); + if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + { + unblock_input (); + return; + } + + XSETFRAME (frame, f); + + if (mb_idx < 0) + { + kbd_buffer_store_help_event (frame, Qnil); + unblock_input (); + return; + } + + vec = f->menu_bar_vector; + if (mb_idx >= ASIZE (vec)) + emacs_abort (); + + help = AREF (vec, mb_idx + MENU_ITEMS_ITEM_HELP); + if (STRINGP (help) || NILP (help)) + kbd_buffer_store_help_event (frame, help); + unblock_input (); +} + +DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, + 0, 0, 0, doc: /* SKIP: real doc in xmenu.c. */) + (void) +{ + return popup_activated_p ? Qt : Qnil; +} + +DEFUN ("haiku-menu-bar-open", Fhaiku_menu_bar_open, Shaiku_menu_bar_open, 0, 1, "i", + doc: /* Show the menu bar in FRAME. + +Move the mouse pointer onto the first element of FRAME's menu bar, and +cause it to be opened. If FRAME is nil or not given, use the selected +frame. If FRAME has no menu bar, a pop-up is displayed at the position +of the last non-menu event instead. */) + (Lisp_Object frame) +{ + struct frame *f = decode_window_system_frame (frame); + + if (FRAME_EXTERNAL_MENU_BAR (f)) + { + if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + set_frame_menubar (f, 1); + } + else + { + return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map), + last_nonmenu_event); + } + + block_input (); + BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); + unblock_input (); + + return Qnil; +} + +void +syms_of_haikumenu (void) +{ + DEFSYM (Qdebug_on_next_call, "debug-on-next-call"); + DEFSYM (Qpopup_menu, "popup-menu"); + DEFSYM (Qmouse_menu_bar_map, "mouse-menu-bar-map"); + + defsubr (&Smenu_or_popup_active_p); + defsubr (&Shaiku_menu_bar_open); + return; +} diff --git a/src/haikuselect.c b/src/haikuselect.c new file mode 100644 index 00000000000..38cceb1de74 --- /dev/null +++ b/src/haikuselect.c @@ -0,0 +1,180 @@ +/* Haiku window system selection support. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "blockinput.h" +#include "coding.h" +#include "haikuselect.h" +#include "haikuterm.h" + +static Lisp_Object +haiku_selection_data_1 (Lisp_Object clipboard) +{ + Lisp_Object result = Qnil; + char *targets[256]; + + block_input (); + if (EQ (clipboard, QPRIMARY)) + BClipboard_primary_targets ((char **) &targets, 256); + else if (EQ (clipboard, QSECONDARY)) + BClipboard_secondary_targets ((char **) &targets, 256); + else if (EQ (clipboard, QCLIPBOARD)) + BClipboard_system_targets ((char **) &targets, 256); + else + { + unblock_input (); + signal_error ("Bad clipboard", clipboard); + } + + for (int i = 0; targets[i]; ++i) + { + result = Fcons (build_unibyte_string (targets[i]), + result); + free (targets[i]); + } + unblock_input (); + + return result; +} + +DEFUN ("haiku-selection-targets", Fhaiku_selection_targets, + Shaiku_selection_targets, 1, 1, 0, + doc: /* Find the types of data available from CLIPBOARD. +CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. +Return the available types as a list of strings. */) + (Lisp_Object clipboard) +{ + return haiku_selection_data_1 (clipboard); +} + +DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, + 2, 2, 0, + doc: /* Retrieve content typed as NAME from the clipboard +CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or +`CLIPBOARD'. NAME is a MIME type denoting the type of the data to +fetch. */) + (Lisp_Object clipboard, Lisp_Object name) +{ + CHECK_SYMBOL (clipboard); + CHECK_STRING (name); + char *dat; + ssize_t len; + + block_input (); + if (EQ (clipboard, QPRIMARY)) + dat = BClipboard_find_primary_selection_data (SSDATA (name), &len); + else if (EQ (clipboard, QSECONDARY)) + dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len); + else if (EQ (clipboard, QCLIPBOARD)) + dat = BClipboard_find_system_data (SSDATA (name), &len); + else + { + unblock_input (); + signal_error ("Bad clipboard", clipboard); + } + unblock_input (); + + if (!dat) + return Qnil; + + Lisp_Object str = make_unibyte_string (dat, len); + Lisp_Object lispy_type = Qnil; + + if (!strcmp (SSDATA (name), "text/utf-8") || + !strcmp (SSDATA (name), "text/plain")) + { + if (string_ascii_p (str)) + lispy_type = QSTRING; + else + lispy_type = QUTF8_STRING; + } + + if (!NILP (lispy_type)) + Fput_text_property (make_fixnum (0), make_fixnum (len), + Qforeign_selection, lispy_type, str); + + block_input (); + BClipboard_free_data (dat); + unblock_input (); + + return str; +} + +DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put, + 3, 4, 0, + doc: /* Add or remove content from the clipboard CLIPBOARD. +CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME +is a MIME type denoting the type of the data to add. DATA is the +string that will be placed in the clipboard, or nil if the content is +to be removed. If NAME is the string "text/utf-8" or the string +"text/plain", encode it as UTF-8 before storing it into the clipboard. +CLEAR, if non-nil, means to erase all the previous contents of the +clipboard. */) + (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data, + Lisp_Object clear) +{ + CHECK_SYMBOL (clipboard); + CHECK_STRING (name); + if (!NILP (data)) + CHECK_STRING (data); + + block_input (); + /* It seems that Haiku applications counter-intuitively expect + UTF-8 data in both text/utf-8 and text/plain. */ + if (!NILP (data) && STRING_MULTIBYTE (data) && + (!strcmp (SSDATA (name), "text/utf-8") || + !strcmp (SSDATA (name), "text/plain"))) + data = ENCODE_UTF_8 (data); + + char *dat = !NILP (data) ? SSDATA (data) : NULL; + ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0; + + if (EQ (clipboard, QPRIMARY)) + BClipboard_set_primary_selection_data (SSDATA (name), dat, len, + !NILP (clear)); + else if (EQ (clipboard, QSECONDARY)) + BClipboard_set_secondary_selection_data (SSDATA (name), dat, len, + !NILP (clear)); + else if (EQ (clipboard, QCLIPBOARD)) + BClipboard_set_system_data (SSDATA (name), dat, len, !NILP (clear)); + else + { + unblock_input (); + signal_error ("Bad clipboard", clipboard); + } + unblock_input (); + + return Qnil; +} + +void +syms_of_haikuselect (void) +{ + DEFSYM (QSECONDARY, "SECONDARY"); + DEFSYM (QCLIPBOARD, "CLIPBOARD"); + DEFSYM (QSTRING, "STRING"); + DEFSYM (QUTF8_STRING, "UTF8_STRING"); + DEFSYM (Qforeign_selection, "foreign-selection"); + DEFSYM (QTARGETS, "TARGETS"); + + defsubr (&Shaiku_selection_data); + defsubr (&Shaiku_selection_put); + defsubr (&Shaiku_selection_targets); +} diff --git a/src/haikuselect.h b/src/haikuselect.h new file mode 100644 index 00000000000..1a3a945f98d --- /dev/null +++ b/src/haikuselect.h @@ -0,0 +1,74 @@ +/* Haiku window system selection support. Hey Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_SELECT_H_ +#define _HAIKU_SELECT_H_ + +#ifdef __cplusplus +#include +#endif + +#ifdef __cplusplus +#include +extern "C" +{ + extern void init_haiku_select (void); +#endif + + /* Whether or not the selection was recently changed. */ + extern int selection_state_flag; + + /* Find a string with the MIME type TYPE in the system clipboard. */ + extern char * + BClipboard_find_system_data (const char *type, ssize_t *len); + + /* Ditto, but for the primary selection and not clipboard. */ + extern char * + BClipboard_find_primary_selection_data (const char *type, ssize_t *len); + + /* Ditto, this time for the secondary selection. */ + extern char * + BClipboard_find_secondary_selection_data (const char *type, ssize_t *len); + + extern void + BClipboard_set_system_data (const char *type, const char *data, ssize_t len, + bool clear); + + extern void + BClipboard_set_primary_selection_data (const char *type, const char *data, + ssize_t len, bool clear); + + extern void + BClipboard_set_secondary_selection_data (const char *type, const char *data, + ssize_t len, bool clear); + + extern void + BClipboard_system_targets (char **buf, int len); + + extern void + BClipboard_primary_targets (char **buf, int len); + + extern void + BClipboard_secondary_targets (char **buf, int len); + + /* Free the returned data. */ + extern void BClipboard_free_data (void *ptr); +#ifdef __cplusplus +}; +#endif +#endif /* _HAIKU_SELECT_H_ */ diff --git a/src/haikuterm.c b/src/haikuterm.c new file mode 100644 index 00000000000..6bf45894065 --- /dev/null +++ b/src/haikuterm.c @@ -0,0 +1,3626 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "dispextern.h" +#include "frame.h" +#include "lisp.h" +#include "haikugui.h" +#include "keyboard.h" +#include "haikuterm.h" +#include "blockinput.h" +#include "termchar.h" +#include "termhooks.h" +#include "menu.h" +#include "buffer.h" +#include "haiku_support.h" +#include "thread.h" +#include "window.h" + +#include +#include + +#ifdef USE_BE_CAIRO +#include +#endif + +struct haiku_display_info *x_display_list = NULL; +extern frame_parm_handler haiku_frame_parm_handlers[]; + +static void **fringe_bmps; +static int fringe_bitmap_fillptr = 0; + +static Lisp_Object rdb; + +struct unhandled_event +{ + struct unhandled_event *next; + enum haiku_event_type type; + uint8_t buffer[200]; +}; + +char * +get_keysym_name (int keysym) +{ + static char value[16]; + sprintf (value, "%d", keysym); + return value; +} + +static struct frame * +haiku_window_to_frame (void *window) +{ + Lisp_Object tail, tem; + struct frame *f; + + FOR_EACH_FRAME (tail, tem) + { + f = XFRAME (tem); + if (!FRAME_HAIKU_P (f)) + continue; + + eassert (FRAME_DISPLAY_INFO (f) == x_display_list); + + if (FRAME_HAIKU_WINDOW (f) == window) + return f; + } + + return 0; +} + +static void +haiku_coords_from_parent (struct frame *f, int *x, int *y) +{ + struct frame *p = FRAME_PARENT_FRAME (f); + eassert (p); + + for (struct frame *parent = p; parent; + parent = FRAME_PARENT_FRAME (parent)) + { + *x -= parent->left_pos; + *y -= parent->top_pos; + } +} + +static void +haiku_delete_terminal (struct terminal *terminal) +{ + emacs_abort (); +} + +static const char * +get_string_resource (void *ignored, const char *name, const char *class) +{ + if (!name) + return NULL; + + Lisp_Object lval = assoc_no_quit (build_string (name), rdb); + + if (!NILP (lval)) + return SSDATA (XCDR (lval)); + + return NULL; +} + +static void +haiku_update_size_hints (struct frame *f) +{ + int base_width, base_height; + eassert (FRAME_HAIKU_P (f) && FRAME_HAIKU_WINDOW (f)); + + base_width = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, 0); + base_height = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, 0); + + block_input (); + BWindow_set_size_alignment (FRAME_HAIKU_WINDOW (f), + frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f), + frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (f)); + BWindow_set_min_size (FRAME_HAIKU_WINDOW (f), base_width, + base_height + + FRAME_TOOL_BAR_HEIGHT (f) + + FRAME_MENU_BAR_HEIGHT (f)); + unblock_input (); +} + +static void +haiku_clip_to_string (struct glyph_string *s) +{ + struct haiku_rect r[2]; + int n = get_glyph_string_clip_rects (s, (struct haiku_rect *) &r, 2); + + if (n) + BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), r[0].x, r[0].y, + r[0].width, r[0].height); + if (n > 1) + { + BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), r[1].x, r[1].y, + r[1].width, r[1].height); + } + + s->num_clips = n; +} + +static void +haiku_clip_to_string_exactly (struct glyph_string *s, struct glyph_string *dst) +{ + BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), s->x, s->y, + s->width, s->height); + dst->num_clips = 1; +} + +static void +haiku_flip_buffers (struct frame *f) +{ + void *view = FRAME_OUTPUT_DATA (f)->view; + block_input (); + + BView_draw_lock (view); + FRAME_DIRTY_P (f) = 0; + EmacsView_flip_and_blit (view); + BView_draw_unlock (view); + + unblock_input (); +} + +static void +haiku_frame_up_to_date (struct frame *f) +{ + block_input (); + FRAME_MOUSE_UPDATE (f); + if (FRAME_DIRTY_P (f) && !buffer_flipping_blocked_p ()) + haiku_flip_buffers (f); + unblock_input (); +} + +static void +haiku_buffer_flipping_unblocked_hook (struct frame *f) +{ + if (FRAME_DIRTY_P (f)) + haiku_flip_buffers (f); +} + +static void +haiku_clear_frame_area (struct frame *f, int x, int y, + int width, int height) +{ + void *vw = FRAME_HAIKU_VIEW (f); + block_input (); + BView_draw_lock (vw); + BView_StartClip (vw); + BView_ClipToRect (vw, x, y, width, height); + BView_SetHighColor (vw, FRAME_BACKGROUND_PIXEL (f)); + BView_FillRectangle (vw, x, y, width, height); + BView_EndClip (vw); + BView_draw_unlock (vw); + unblock_input (); +} + +static void +haiku_clear_frame (struct frame *f) +{ + void *view = FRAME_HAIKU_VIEW (f); + block_input (); + BView_draw_lock (view); + BView_StartClip (view); + BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f) + 1, + FRAME_PIXEL_HEIGHT (f) + 1); + BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f)); + BView_FillRectangle (view, 0, 0, FRAME_PIXEL_WIDTH (f) + 1, + FRAME_PIXEL_HEIGHT (f) + 1); + BView_EndClip (view); + BView_draw_unlock (view); + unblock_input (); +} + +/* Give frame F the font FONT-OBJECT as its default font. The return + value is FONT-OBJECT. FONTSET is an ID of the fontset for the + frame. If it is negative, generate a new fontset from + FONT-OBJECT. */ + +static Lisp_Object +haiku_new_font (struct frame *f, Lisp_Object font_object, int fontset) +{ + struct font *font = XFONT_OBJECT (font_object); + if (fontset < 0) + fontset = fontset_from_font (font_object); + + FRAME_FONTSET (f) = fontset; + if (FRAME_FONT (f) == font) + return font_object; + + FRAME_FONT (f) = font; + FRAME_BASELINE_OFFSET (f) = font->baseline_offset; + FRAME_COLUMN_WIDTH (f) = font->average_width; + + int ascent, descent; + get_font_ascent_descent (font, &ascent, &descent); + FRAME_LINE_HEIGHT (f) = ascent + descent; + FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f); + + int unit = FRAME_COLUMN_WIDTH (f); + if (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0) + FRAME_CONFIG_SCROLL_BAR_COLS (f) + = (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + unit - 1) / unit; + else + FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + unit - 1) / unit; + + if (FRAME_HAIKU_WINDOW (f)) + { + adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), + FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), + 3, false, Qfont); + + haiku_clear_under_internal_border (f); + } + return font_object; +} + +static int +haiku_valid_modifier_p (Lisp_Object sym) +{ + return EQ (sym, Qcommand) || EQ (sym, Qshift) + || EQ (sym, Qcontrol) || EQ (sym, Qoption); +} + +#define MODIFIER_OR(obj, def) (haiku_valid_modifier_p (obj) ? obj : def) + +static void +haiku_add_modifier (int modifier, int toput, Lisp_Object qtem, int *modifiers) +{ + if ((modifier & HAIKU_MODIFIER_ALT && EQ (qtem, Qcommand)) + || (modifier & HAIKU_MODIFIER_SHIFT && EQ (qtem, Qshift)) + || (modifier & HAIKU_MODIFIER_CTRL && EQ (qtem, Qcontrol)) + || (modifier & HAIKU_MODIFIER_SUPER && EQ (qtem, Qoption))) + *modifiers |= toput; +} + +static int +haiku_modifiers_to_emacs (int haiku_key) +{ + int modifiers = 0; + haiku_add_modifier (haiku_key, shift_modifier, + MODIFIER_OR (Vhaiku_shift_keysym, Qshift), &modifiers); + haiku_add_modifier (haiku_key, super_modifier, + MODIFIER_OR (Vhaiku_super_keysym, Qoption), &modifiers); + haiku_add_modifier (haiku_key, meta_modifier, + MODIFIER_OR (Vhaiku_meta_keysym, Qcommand), &modifiers); + haiku_add_modifier (haiku_key, ctrl_modifier, + MODIFIER_OR (Vhaiku_control_keysym, Qcontrol), &modifiers); + return modifiers; +} + +#undef MODIFIER_OR + +static void +haiku_rehighlight (void) +{ + eassert (x_display_list && !x_display_list->next); + + block_input (); + + struct frame *old_hl = x_display_list->highlight_frame; + + if (x_display_list->focused_frame) + { + x_display_list->highlight_frame + = ((FRAMEP (FRAME_FOCUS_FRAME (x_display_list->focused_frame))) + ? XFRAME (FRAME_FOCUS_FRAME (x_display_list->focused_frame)) + : x_display_list->focused_frame); + if (!FRAME_LIVE_P (x_display_list->highlight_frame)) + { + fset_focus_frame (x_display_list->focused_frame, Qnil); + x_display_list->highlight_frame = x_display_list->focused_frame; + } + } + else + x_display_list->highlight_frame = 0; + + if (old_hl) + gui_update_cursor (old_hl, true); + + if (x_display_list->highlight_frame) + gui_update_cursor (x_display_list->highlight_frame, true); + unblock_input (); +} + +static void +haiku_frame_raise_lower (struct frame *f, bool raise_p) +{ + if (raise_p) + { + block_input (); + BWindow_activate (FRAME_HAIKU_WINDOW (f)); + flush_frame (f); + unblock_input (); + } +} + +/* Unfortunately, NOACTIVATE is not implementable on Haiku. */ +static void +haiku_focus_frame (struct frame *frame, bool noactivate) +{ + if (x_display_list->focused_frame != frame) + haiku_frame_raise_lower (frame, 1); +} + +static void +haiku_new_focus_frame (struct frame *frame) +{ + eassert (x_display_list && !x_display_list->next); + + block_input (); + if (frame != x_display_list->focused_frame) + { + if (x_display_list->focused_frame && + x_display_list->focused_frame->auto_lower) + haiku_frame_raise_lower (x_display_list->focused_frame, 0); + + x_display_list->focused_frame = frame; + + if (frame && frame->auto_raise) + haiku_frame_raise_lower (frame, 1); + } + unblock_input (); + + haiku_rehighlight (); +} + +static void +haiku_implicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + haiku_set_name (f, arg, 0); +} + +static void +haiku_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor) +{ + haiku_query_color (FRAME_BACKGROUND_PIXEL (f), bgcolor); +} + +static bool +haiku_defined_color (struct frame *f, + const char *name, + Emacs_Color *color, + bool alloc, + bool make_index) +{ + return !haiku_get_color (name, color); +} + +/* Adapted from xterm `x_draw_box_rect'. */ +static void +haiku_draw_box_rect (struct glyph_string *s, + int left_x, int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, struct haiku_rect *clip_rect) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + struct face *face = s->face; + + BView_StartClip (view); + BView_SetHighColor (view, face->box_color); + if (clip_rect) + BView_ClipToRect (view, clip_rect->x, clip_rect->y, clip_rect->width, + clip_rect->height); + BView_FillRectangle (view, left_x, top_y, right_x - left_x + 1, hwidth); + if (left_p) + BView_FillRectangle (view, left_x, top_y, vwidth, bottom_y - top_y + 1); + + BView_FillRectangle (view, left_x, bottom_y - hwidth + 1, + right_x - left_x + 1, hwidth); + if (right_p) + BView_FillRectangle (view, right_x - vwidth + 1, + top_y, vwidth, bottom_y - top_y + 1); + BView_EndClip (view); +} + +static void +haiku_calculate_relief_colors (struct glyph_string *s, + uint32_t *rgbout_w, uint32_t *rgbout_b, + uint32_t *rgbout_c) +{ + struct face *face = s->face; + + prepare_face_for_display (s->f, s->face); + + uint32_t rgbin = face->use_box_color_for_shadows_p + ? face->box_color : face->background; + + if (s->hl == DRAW_CURSOR) + rgbin = FRAME_CURSOR_COLOR (s->f).pixel; + + double h, cs, l; + rgb_color_hsl (rgbin, &h, &cs, &l); + + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 0.6), rgbout_b); + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.2), rgbout_w); + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.8), rgbout_c); +} + +static void +haiku_draw_relief_rect (struct glyph_string *s, + int left_x, int top_y, int right_x, int bottom_y, + int hwidth, int vwidth, bool raised_p, bool top_p, bool bot_p, + bool left_p, bool right_p, + struct haiku_rect *clip_rect, bool fancy_p) +{ + uint32_t color_white; + uint32_t color_black; + uint32_t color_corner; + + haiku_calculate_relief_colors (s, &color_white, &color_black, + &color_corner); + + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + + BView_SetHighColor (view, raised_p ? color_white : color_black); + if (clip_rect) + BView_ClipToRect (view, clip_rect->x, clip_rect->y, clip_rect->width, + clip_rect->height); + if (top_p) + BView_FillRectangle (view, left_x, top_y, right_x - left_x + 1, hwidth); + if (left_p) + BView_FillRectangle (view, left_x, top_y, vwidth, bottom_y - top_y + 1); + BView_SetHighColor (view, !raised_p ? color_white : color_black); + + if (bot_p) + BView_FillRectangle (view, left_x, bottom_y - hwidth + 1, + right_x - left_x + 1, hwidth); + if (right_p) + BView_FillRectangle (view, right_x - vwidth + 1, top_y, + vwidth, bottom_y - top_y + 1); + + /* Draw the triangle for the bottom-left corner. */ + if (bot_p && left_p) + { + BView_SetHighColor (view, raised_p ? color_white : color_black); + BView_FillTriangle (view, left_x, bottom_y - hwidth, left_x + vwidth, + bottom_y - hwidth, left_x, bottom_y); + } + + /* Now draw the triangle for the top-right corner. */ + if (top_p && right_p) + { + BView_SetHighColor (view, raised_p ? color_white : color_black); + BView_FillTriangle (view, right_x - vwidth, top_y, + right_x, top_y, + right_x - vwidth, top_y + hwidth); + } + + /* If (h/v)width is > 1, we draw the outer-most line on each side in the + black relief color. */ + + BView_SetHighColor (view, color_black); + + if (hwidth > 1 && top_p) + BView_StrokeLine (view, left_x, top_y, right_x, top_y); + if (hwidth > 1 && bot_p) + BView_StrokeLine (view, left_x, bottom_y, right_x, bottom_y); + if (vwidth > 1 && left_p) + BView_StrokeLine (view, left_x, top_y, left_x, bottom_y); + if (vwidth > 1 && right_p) + BView_StrokeLine (view, right_x, top_y, right_x, bottom_y); + + BView_SetHighColor (view, color_corner); + + /* Omit corner pixels. */ + if (hwidth > 1 || vwidth > 1) + { + if (left_p && top_p) + BView_FillRectangle (view, left_x, top_y, 1, 1); + if (left_p && bot_p) + BView_FillRectangle (view, left_x, bottom_y, 1, 1); + if (right_p && top_p) + BView_FillRectangle (view, right_x, top_y, 1, 1); + if (right_p && bot_p) + BView_FillRectangle (view, right_x, bottom_y, 1, 1); + } + + BView_EndClip (view); +} + +static void +haiku_draw_string_box (struct glyph_string *s, int clip_p) +{ + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; + bool raised_p, left_p, right_p; + struct glyph *last_glyph; + struct haiku_rect clip_rect; + + struct face *face = s->face; + + last_x = ((s->row->full_width_p && !s->w->pseudo_window_p) + ? WINDOW_RIGHT_EDGE_X (s->w) + : window_box_right (s->w, s->area)); + + /* The glyph that may have a right box line. For static + compositions and images, the right-box flag is on the first glyph + of the glyph string; for other types it's on the last glyph. */ + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + /* For automatic compositions, we need to look up the last glyph + in the composition. */ + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; + + vwidth = eabs (face->box_vertical_line_width); + hwidth = eabs (face->box_horizontal_line_width); + raised_p = face->box == FACE_RAISED_BOX; + left_x = s->x; + right_x = (s->row->full_width_p && s->extends_to_end_of_line_p + ? last_x - 1 + : min (last_x, s->x + s->background_width) - 1); + + top_y = s->y; + bottom_y = top_y + s->height - 1; + + left_p = (s->first_glyph->left_box_line_p + || (s->hl == DRAW_MOUSE_FACE + && (s->prev == NULL + || s->prev->hl != s->hl))); + right_p = (last_glyph->right_box_line_p + || (s->hl == DRAW_MOUSE_FACE + && (s->next == NULL + || s->next->hl != s->hl))); + + get_glyph_string_clip_rect (s, &clip_rect); + + if (face->box == FACE_SIMPLE_BOX) + haiku_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); + else + haiku_draw_relief_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, true, true, left_p, right_p, + &clip_rect, 1); + + if (clip_p) + { + void *view = FRAME_HAIKU_VIEW (s->f); + BView_ClipToInverseRect (view, left_x, top_y, right_x - left_x + 1, hwidth); + if (left_p) + BView_ClipToInverseRect (view, left_x, top_y, vwidth, bottom_y - top_y + 1); + BView_ClipToInverseRect (view, left_x, bottom_y - hwidth + 1, + right_x - left_x + 1, hwidth); + if (right_p) + BView_ClipToInverseRect (view, right_x - vwidth + 1, + top_y, vwidth, bottom_y - top_y + 1); + } +} + +static void +haiku_draw_plain_background (struct glyph_string *s, struct face *face, + int box_line_hwidth, int box_line_vwidth) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel); + else + BView_SetHighColor (view, face->background_defaulted_p ? + FRAME_BACKGROUND_PIXEL (s->f) : + face->background); + + BView_FillRectangle (view, s->x, + s->y + box_line_hwidth, + s->background_width, + s->height - 2 * box_line_hwidth); + BView_EndClip (view); +} + +static void +haiku_draw_stipple_background (struct glyph_string *s, struct face *face, + int box_line_hwidth, int box_line_vwidth) +{ +} + +static void +haiku_maybe_draw_background (struct glyph_string *s, int force_p) +{ + if ((s->first_glyph->type != IMAGE_GLYPH) && !s->background_filled_p) + { + struct face *face = s->face; + int box_line_width = max (face->box_horizontal_line_width, 0); + int box_vline_width = max (face->box_vertical_line_width, 0); + + if (FONT_HEIGHT (s->font) < s->height - 2 * box_vline_width + || FONT_TOO_HIGH (s->font) + || s->font_not_found_p || s->extends_to_end_of_line_p || force_p) + { + if (!face->stipple) + haiku_draw_plain_background (s, face, box_line_width, + box_vline_width); + else + haiku_draw_stipple_background (s, face, box_line_width, + box_vline_width); + s->background_filled_p = 1; + } + } +} + +static void +haiku_mouse_face_colors (struct glyph_string *s, uint32_t *fg, + uint32_t *bg) +{ + int face_id; + struct face *face; + + /* What face has to be used last for the mouse face? */ + face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id; + face = FACE_FROM_ID_OR_NULL (s->f, face_id); + if (face == NULL) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + + if (s->first_glyph->type == CHAR_GLYPH) + face_id = FACE_FOR_CHAR (s->f, face, s->first_glyph->u.ch, -1, Qnil); + else + face_id = FACE_FOR_CHAR (s->f, face, 0, -1, Qnil); + + face = FACE_FROM_ID (s->f, face_id); + prepare_face_for_display (s->f, s->face); + + if (fg) + *fg = face->foreground; + if (bg) + *bg = face->background; +} + +static void +haiku_draw_underwave (struct glyph_string *s, int width, int x) +{ + int wave_height = 3, wave_length = 2; + int y, dx, dy, odd, xmax; + dx = wave_length; + dy = wave_height - 1; + y = s->ybase - wave_height + 3; + + float ax, ay, bx, by; + xmax = x + width; + + void *view = FRAME_HAIKU_VIEW (s->f); + + BView_StartClip (view); + BView_ClipToRect (view, x, y, width, wave_height); + ax = x - ((int) (x) % dx) + (float) 0.5; + bx = ax + dx; + odd = (int) (ax / dx) % 2; + ay = by = y + 0.5; + + if (odd) + ay += dy; + else + by += dy; + + while (ax <= xmax) + { + BView_StrokeLine (view, ax, ay, bx, by); + ax = bx, ay = by; + bx += dx, by = y + 0.5 + odd * dy; + odd = !odd; + } + BView_EndClip (view); +} + +static void +haiku_draw_text_decoration (struct glyph_string *s, struct face *face, + uint8_t dcol, int width, int x) +{ + if (s->for_overlaps) + return; + + void *view = FRAME_HAIKU_VIEW (s->f); + BView_draw_lock (view); + BView_StartClip (view); + + if (face->underline) + { + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else if (!face->underline_defaulted_p) + BView_SetHighColor (view, face->underline_color); + else + BView_SetHighColor (view, dcol); + + if (face->underline == FACE_UNDER_WAVE) + haiku_draw_underwave (s, width, x); + else if (face->underline == FACE_UNDER_LINE) + { + unsigned long thickness, position; + int y; + + if (s->prev && s->prev && s->prev->hl == DRAW_MOUSE_FACE) + { + struct face *prev_face = s->prev->face; + + if (prev_face && prev_face->underline == FACE_UNDER_LINE) + { + /* We use the same underline style as the previous one. */ + thickness = s->prev->underline_thickness; + position = s->prev->underline_position; + } + else + goto calculate_underline_metrics; + } + else + { + calculate_underline_metrics:; + struct font *font = font_for_underline_metrics (s); + unsigned long minimum_offset; + bool underline_at_descent_line; + bool use_underline_position_properties; + Lisp_Object val = (WINDOW_BUFFER_LOCAL_VALUE + (Qunderline_minimum_offset, s->w)); + + if (FIXNUMP (val)) + minimum_offset = max (0, XFIXNUM (val)); + else + minimum_offset = 1; + + val = (WINDOW_BUFFER_LOCAL_VALUE + (Qx_underline_at_descent_line, s->w)); + underline_at_descent_line + = !(NILP (val) || EQ (val, Qunbound)); + + val = (WINDOW_BUFFER_LOCAL_VALUE + (Qx_use_underline_position_properties, s->w)); + use_underline_position_properties + = !(NILP (val) || EQ (val, Qunbound)); + + /* Get the underline thickness. Default is 1 pixel. */ + if (font && font->underline_thickness > 0) + thickness = font->underline_thickness; + else + thickness = 1; + if (underline_at_descent_line) + position = (s->height - thickness) - (s->ybase - s->y); + else + { + /* Get the underline position. This is the + recommended vertical offset in pixels from + the baseline to the top of the underline. + This is a signed value according to the + specs, and its default is + + ROUND ((maximum descent) / 2), with + ROUND(x) = floor (x + 0.5) */ + + if (use_underline_position_properties + && font && font->underline_position >= 0) + position = font->underline_position; + else if (font) + position = (font->descent + 1) / 2; + else + position = minimum_offset; + } + position = max (position, minimum_offset); + } + /* Check the sanity of thickness and position. We should + avoid drawing underline out of the current line area. */ + if (s->y + s->height <= s->ybase + position) + position = (s->height - 1) - (s->ybase - s->y); + 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; + + BView_FillRectangle (view, s->x, y, s->width, thickness); + } + } + + if (face->overline_p) + { + unsigned long dy = 0, h = 1; + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else if (!face->overline_color_defaulted_p) + BView_SetHighColor (view, face->overline_color); + else + BView_SetHighColor (view, dcol); + + BView_FillRectangle (view, s->x, s->y + dy, s->width, h); + } + + if (face->strike_through_p) + { + /* Y-coordinate and height of the glyph string's first + glyph. We cannot use s->y and s->height because those + could be larger if there are taller display elements + (e.g., characters displayed with a larger font) in the + same glyph row. */ + int glyph_y = s->ybase - s->first_glyph->ascent; + int glyph_height = s->first_glyph->ascent + s->first_glyph->descent; + /* Strike-through width and offset from the glyph string's + top edge. */ + unsigned long h = 1; + unsigned long dy = (glyph_height - h) / 2; + + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else if (!face->strike_through_color_defaulted_p) + BView_SetHighColor (view, face->strike_through_color); + else + BView_SetHighColor (view, dcol); + + BView_FillRectangle (view, s->x, glyph_y + dy, s->width, h); + } + + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_draw_glyph_string_foreground (struct glyph_string *s) +{ + struct face *face = s->face; + + int i, x; + if (face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (face->box_vertical_line_width, 0); + else + x = s->x; + + void *view = FRAME_HAIKU_VIEW (s->f); + + if (s->font_not_found_p) + { + BView_StartClip (view); + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else + BView_SetHighColor (view, face->foreground); + for (i = 0; i < s->nchars; ++i) + { + struct glyph *g = s->first_glyph + i; + BView_StrokeRectangle (view, x, s->y, g->pixel_width, + s->height); + x += g->pixel_width; + } + BView_EndClip (view); + } + else + { + struct font *ft = s->font; + int off = ft->baseline_offset; + int y; + + if (ft->vertical_centering) + off = VCENTER_BASELINE_OFFSET (ft, s->f) - off; + y = s->ybase - off; + if (s->for_overlaps || (s->background_filled_p && s->hl != DRAW_CURSOR)) + ft->driver->draw (s, 0, s->nchars, x, y, false); + else + ft->driver->draw (s, 0, s->nchars, x, y, true); + + if (face->overstrike) + ft->driver->draw (s, 0, s->nchars, x + 1, y, false); + } +} + +static void +haiku_draw_glyphless_glyph_string_foreground (struct glyph_string *s) +{ + struct glyph *glyph = s->first_glyph; + unsigned char2b[8]; + int x, i, j; + struct face *face = s->face; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (face && face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (face->box_vertical_line_width, 0); + else + x = s->x; + + s->char2b = char2b; + + for (i = 0; i < s->nchars; i++, glyph++) + { +#ifdef GCC_LINT + enum { PACIFY_GCC_BUG_81401 = 1 }; +#else + enum { PACIFY_GCC_BUG_81401 = 0 }; +#endif + char buf[7 + PACIFY_GCC_BUG_81401]; + char *str = NULL; + int len = glyph->u.glyphless.len; + + if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM) + { + if (len > 0 + && CHAR_TABLE_P (Vglyphless_char_display) + && (CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (Vglyphless_char_display)) + >= 1)) + { + Lisp_Object acronym + = (! glyph->u.glyphless.for_no_font + ? CHAR_TABLE_REF (Vglyphless_char_display, + glyph->u.glyphless.ch) + : XCHAR_TABLE (Vglyphless_char_display)->extras[0]); + if (STRINGP (acronym)) + str = SSDATA (acronym); + } + } + else if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_HEX_CODE) + { + unsigned int ch = glyph->u.glyphless.ch; + eassume (ch <= MAX_CHAR); + sprintf (buf, "%0*X", ch < 0x10000 ? 4 : 6, ch); + str = buf; + } + + if (str) + { + int upper_len = (len + 1) / 2; + + /* It is assured that all LEN characters in STR is ASCII. */ + for (j = 0; j < len; j++) + char2b[j] = s->font->driver->encode_char (s->font, str[j]) & 0xFFFF; + + s->font->driver->draw (s, 0, upper_len, + x + glyph->slice.glyphless.upper_xoff, + s->ybase + glyph->slice.glyphless.upper_yoff, + false); + s->font->driver->draw (s, upper_len, len, + x + glyph->slice.glyphless.lower_xoff, + s->ybase + glyph->slice.glyphless.lower_yoff, + false); + } + BView_StartClip (FRAME_HAIKU_VIEW (s->f)); + if (glyph->u.glyphless.method != GLYPHLESS_DISPLAY_THIN_SPACE) + BView_FillRectangle (FRAME_HAIKU_VIEW (s->f), + x, s->ybase - glyph->ascent, + glyph->pixel_width - 1, + glyph->ascent + glyph->descent - 1); + BView_EndClip (FRAME_HAIKU_VIEW (s->f)); + x += glyph->pixel_width; + } +} + +static void +haiku_draw_stretch_glyph_string (struct glyph_string *s) +{ + eassert (s->first_glyph->type == STRETCH_GLYPH); + + struct face *face = s->face; + + if (s->hl == DRAW_CURSOR && !x_stretch_cursor_p) + { + int width, background_width = s->background_width; + int x = s->x; + + if (!s->row->reversed_p) + { + int left_x = window_box_left_offset (s->w, TEXT_AREA); + + if (x < left_x) + { + background_width -= left_x - x; + x = left_x; + } + } + else + { + /* In R2L rows, draw the cursor on the right edge of the + stretch glyph. */ + int right_x = window_box_right (s->w, TEXT_AREA); + if (x + background_width > right_x) + background_width -= x - right_x; + x += background_width; + } + + width = min (FRAME_COLUMN_WIDTH (s->f), background_width); + if (s->row->reversed_p) + x -= width; + + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel); + BView_FillRectangle (view, x, s->y, width, s->height); + BView_EndClip (view); + + if (width < background_width) + { + if (!s->row->reversed_p) + x += width; + else + x = s->x; + + int y = s->y; + int w = background_width - width, h = s->height; + + if (!face->stipple) + { + uint32_t bkg; + if (s->hl == DRAW_MOUSE_FACE || (s->hl == DRAW_CURSOR + && s->row->mouse_face_p + && cursor_in_mouse_face_p (s->w))) + haiku_mouse_face_colors (s, NULL, &bkg); + else + bkg = face->background; + + BView_StartClip (view); + BView_SetHighColor (view, bkg); + BView_FillRectangle (view, x, y, w, h); + BView_EndClip (view); + } + } + } + else if (!s->background_filled_p) + { + int background_width = s->background_width; + int x = s->x, text_left_x = window_box_left (s->w, TEXT_AREA); + + /* Don't draw into left fringe or scrollbar area except for + header line and mode line. */ + if (s->area == TEXT_AREA + && x < text_left_x && !s->row->mode_line_p) + { + background_width -= text_left_x - x; + x = text_left_x; + } + + if (background_width > 0) + { + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + uint32_t bkg; + if (s->hl == DRAW_MOUSE_FACE) + haiku_mouse_face_colors (s, NULL, &bkg); + else if (s->hl == DRAW_CURSOR) + bkg = FRAME_CURSOR_COLOR (s->f).pixel; + else + bkg = s->face->background; + + BView_SetHighColor (view, bkg); + BView_FillRectangle (view, x, s->y, background_width, s->height); + BView_EndClip (view); + } + } + s->background_filled_p = 1; +} + +static void +haiku_start_clip (struct glyph_string *s) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + BView_draw_lock (view); + BView_StartClip (view); +} + +static void +haiku_end_clip (struct glyph_string *s) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_clip_to_row (struct window *w, struct glyph_row *row, + enum glyph_row_area area) +{ + struct frame *f = WINDOW_XFRAME (w); + int window_x, window_y, window_width; + int x, y, width, height; + + window_box (w, area, &window_x, &window_y, &window_width, 0); + + x = window_x; + y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, row->y)); + y = max (y, window_y); + width = window_width; + height = row->visible_height; + + BView_ClipToRect (FRAME_HAIKU_VIEW (f), x, y, width, height); +} + +static void +haiku_update_begin (struct frame *f) +{ +} + +static void +haiku_update_end (struct frame *f) +{ + MOUSE_HL_INFO (f)->mouse_face_defer = false; + flush_frame (f); +} + +static void +haiku_draw_composite_glyph_string_foreground (struct glyph_string *s) +{ + int i, j, x; + struct font *font = s->font; + void *view = FRAME_HAIKU_VIEW (s->f); + struct face *face = s->face; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (face && face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (face->box_vertical_line_width, 0); + else + x = s->x; + + /* S is a glyph string for a composition. S->cmp_from is the index + of the first character drawn for glyphs of this composition. + S->cmp_from == 0 means we are drawing the very first character of + this composition. */ + + /* Draw a rectangle for the composition if the font for the very + first character of the composition could not be loaded. */ + + if (s->font_not_found_p && !s->cmp_from) + { + BView_StartClip (view); + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else + BView_SetHighColor (view, s->face->foreground); + BView_StrokeRectangle (view, s->x, s->y, s->width - 1, s->height - 1); + BView_EndClip (view); + } + else if (!s->first_glyph->u.cmp.automatic) + { + int y = s->ybase; + + for (i = 0, j = s->cmp_from; i < s->nchars; i++, j++) + /* TAB in a composition means display glyphs with padding + space on the left or right. */ + if (COMPOSITION_GLYPH (s->cmp, j) != '\t') + { + int xx = x + s->cmp->offsets[j * 2]; + int yy = y - s->cmp->offsets[j * 2 + 1]; + + font->driver->draw (s, j, j + 1, xx, yy, false); + if (face->overstrike) + font->driver->draw (s, j, j + 1, xx + 1, yy, false); + } + } + else + { + Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); + Lisp_Object glyph; + int y = s->ybase; + int width = 0; + + for (i = j = s->cmp_from; i < s->cmp_to; i++) + { + glyph = LGSTRING_GLYPH (gstring, i); + if (NILP (LGLYPH_ADJUSTMENT (glyph))) + width += LGLYPH_WIDTH (glyph); + else + { + int xoff, yoff, wadjust; + + if (j < i) + { + font->driver->draw (s, j, i, x, y, false); + if (s->face->overstrike) + font->driver->draw (s, j, i, x + 1, y, false); + x += width; + } + xoff = LGLYPH_XOFF (glyph); + yoff = LGLYPH_YOFF (glyph); + wadjust = LGLYPH_WADJUST (glyph); + font->driver->draw (s, i, i + 1, x + xoff, y + yoff, false); + if (face->overstrike) + font->driver->draw (s, i, i + 1, x + xoff + 1, y + yoff, + false); + x += wadjust; + j = i + 1; + width = 0; + } + } + if (j < i) + { + font->driver->draw (s, j, i, x, y, false); + if (face->overstrike) + font->driver->draw (s, j, i, x + 1, y, false); + } + } +} + +static void +haiku_draw_image_relief (struct glyph_string *s) +{ + int x1, y1, thick; + bool raised_p, top_p, bot_p, left_p, right_p; + int extra_x, extra_y; + struct haiku_rect r; + int x = s->x; + int y = s->ybase - image_ascent (s->img, s->face, &s->slice); + + struct face *face = s->face; + + /* If first glyph of S has a left box line, start drawing it to the + right of that line. */ + if (face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p + && s->slice.x == 0) + x += max (face->box_vertical_line_width, 0); + + /* If there is a margin around the image, adjust x- and y-position + by that margin. */ + if (s->slice.x == 0) + x += s->img->hmargin; + if (s->slice.y == 0) + y += s->img->vmargin; + + if (s->hl == DRAW_IMAGE_SUNKEN + || s->hl == DRAW_IMAGE_RAISED) + { + if (s->face->id == TAB_BAR_FACE_ID) + thick = (tab_bar_button_relief < 0 + ? DEFAULT_TAB_BAR_BUTTON_RELIEF + : min (tab_bar_button_relief, 1000000)); + else + thick = (tool_bar_button_relief < 0 + ? DEFAULT_TOOL_BAR_BUTTON_RELIEF + : min (tool_bar_button_relief, 1000000)); + raised_p = s->hl == DRAW_IMAGE_RAISED; + } + else + { + thick = eabs (s->img->relief); + raised_p = s->img->relief > 0; + } + + x1 = x + s->slice.width - 1; + y1 = y + s->slice.height - 1; + + extra_x = extra_y = 0; + + if (s->face->id == TAB_BAR_FACE_ID) + { + if (CONSP (Vtab_bar_button_margin) + && FIXNUMP (XCAR (Vtab_bar_button_margin)) + && FIXNUMP (XCDR (Vtab_bar_button_margin))) + { + extra_x = XFIXNUM (XCAR (Vtab_bar_button_margin)) - thick; + extra_y = XFIXNUM (XCDR (Vtab_bar_button_margin)) - thick; + } + else if (FIXNUMP (Vtab_bar_button_margin)) + extra_x = extra_y = XFIXNUM (Vtab_bar_button_margin) - thick; + } + + if (s->face->id == TOOL_BAR_FACE_ID) + { + if (CONSP (Vtool_bar_button_margin) + && FIXNUMP (XCAR (Vtool_bar_button_margin)) + && FIXNUMP (XCDR (Vtool_bar_button_margin))) + { + extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin)); + extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin)); + } + else if (FIXNUMP (Vtool_bar_button_margin)) + extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin); + } + + top_p = bot_p = left_p = right_p = 0; + + if (s->slice.x == 0) + x -= thick + extra_x, left_p = 1; + if (s->slice.y == 0) + y -= thick + extra_y, top_p = 1; + if (s->slice.x + s->slice.width == s->img->width) + x1 += thick + extra_x, right_p = 1; + if (s->slice.y + s->slice.height == s->img->height) + y1 += thick + extra_y, bot_p = 1; + + get_glyph_string_clip_rect (s, &r); + haiku_draw_relief_rect (s, x, y, x1, y1, thick, thick, raised_p, + top_p, bot_p, left_p, right_p, &r, 0); +} + +static void +haiku_draw_image_glyph_string (struct glyph_string *s) +{ + struct face *face = s->face; + + int box_line_hwidth = max (face->box_vertical_line_width, 0); + int box_line_vwidth = max (face->box_horizontal_line_width, 0); + + int x, y; + int height, width; + + height = s->height; + if (s->slice.y == 0) + height -= box_line_vwidth; + if (s->slice.y + s->slice.height >= s->img->height) + height -= box_line_vwidth; + + width = s->background_width; + x = s->x; + if (s->first_glyph->left_box_line_p + && s->slice.x == 0) + { + x += box_line_hwidth; + width -= box_line_hwidth; + } + + y = s->y; + if (s->slice.y == 0) + y += box_line_vwidth; + + void *view = FRAME_HAIKU_VIEW (s->f); + void *bitmap = s->img->pixmap; + + s->stippled_p = face->stipple != 0; + + BView_draw_lock (view); + BView_StartClip (view); + BView_SetHighColor (view, face->background); + BView_FillRectangle (view, x, y, width, height); + BView_EndClip (view); + BView_draw_unlock (view); + + if (bitmap) + { + struct haiku_rect nr; + Emacs_Rectangle cr, ir, r; + + get_glyph_string_clip_rect (s, &nr); + CONVERT_TO_EMACS_RECT (cr, nr); + x = s->x; + y = s->ybase - image_ascent (s->img, face, &s->slice); + + if (s->slice.x == 0) + x += s->img->hmargin; + if (s->slice.y == 0) + y += s->img->vmargin; + + if (face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p + && s->slice.x == 0) + x += max (face->box_vertical_line_width, 0); + + ir.x = x; + ir.y = y; + ir.width = s->slice.width; + ir.height = s->slice.height; + r = ir; + + void *mask = s->img->mask; + + if (gui_intersect_rectangles (&cr, &ir, &r)) + { + BView_draw_lock (view); + BView_StartClip (view); + + haiku_clip_to_string (s); + if (s->img->have_be_transforms_p) + { + bitmap = BBitmap_transform_bitmap (bitmap, + s->img->mask, + face->background, + s->img->be_rotate, + s->img->width, + s->img->height); + mask = NULL; + } + + BView_DrawBitmap (view, bitmap, + s->slice.x + r.x - x, + s->slice.y + r.y - y, + r.width, r.height, + r.x, r.y, r.width, r.height); + if (mask) + { + BView_DrawMask (mask, view, + s->slice.x + r.x - x, + s->slice.y + r.y - y, + r.width, r.height, + r.x, r.y, r.width, r.height, + face->background); + } + + if (s->img->have_be_transforms_p) + BBitmap_free (bitmap); + BView_EndClip (view); + BView_draw_unlock (view); + } + + if (s->hl == DRAW_CURSOR) + { + BView_draw_lock (view); + BView_StartClip (view); + BView_SetPenSize (view, 1); + BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel); + BView_StrokeRectangle (view, r.x, r.y, r.width, r.height); + BView_EndClip (view); + BView_draw_unlock (view); + } + } + + if (s->img->relief + || s->hl == DRAW_IMAGE_RAISED + || s->hl == DRAW_IMAGE_SUNKEN) + haiku_draw_image_relief (s); +} + +static void +haiku_draw_glyph_string (struct glyph_string *s) +{ + block_input (); + prepare_face_for_display (s->f, s->face); + + struct face *face = s->face; + if (face != s->face) + prepare_face_for_display (s->f, face); + + if (s->next && s->right_overhang && !s->for_overlaps) + { + int width; + struct glyph_string *next; + + for (width = 0, next = s->next; + next && width < s->right_overhang; + width += next->width, next = next->next) + if (next->first_glyph->type != IMAGE_GLYPH) + { + prepare_face_for_display (s->f, s->next->face); + haiku_start_clip (s->next); + haiku_clip_to_string (s->next); + if (next->first_glyph->type != STRETCH_GLYPH) + haiku_maybe_draw_background (s->next, 1); + else + haiku_draw_stretch_glyph_string (s->next); + next->num_clips = 0; + haiku_end_clip (s); + } + } + + haiku_start_clip (s); + + int box_filled_p = 0; + + if (!s->for_overlaps && face->box != FACE_NO_BOX + && (s->first_glyph->type == CHAR_GLYPH + || s->first_glyph->type == COMPOSITE_GLYPH)) + { + haiku_clip_to_string (s); + haiku_maybe_draw_background (s, 1); + box_filled_p = 1; + haiku_draw_string_box (s, 0); + } + else if (!s->clip_head && !s->clip_tail && + ((s->prev && s->left_overhang && s->prev->hl != s->hl) || + (s->next && s->right_overhang && s->next->hl != s->hl))) + haiku_clip_to_string_exactly (s, s); + else + haiku_clip_to_string (s); + + if (s->for_overlaps) + s->background_filled_p = 1; + + switch (s->first_glyph->type) + { + case COMPOSITE_GLYPH: + if (s->for_overlaps || (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic)) + s->background_filled_p = 1; + else + haiku_maybe_draw_background (s, 1); + haiku_draw_composite_glyph_string_foreground (s); + break; + case CHAR_GLYPH: + if (s->for_overlaps) + s->background_filled_p = 1; + else + haiku_maybe_draw_background (s, 0); + haiku_draw_glyph_string_foreground (s); + break; + case STRETCH_GLYPH: + haiku_draw_stretch_glyph_string (s); + break; + case IMAGE_GLYPH: + haiku_draw_image_glyph_string (s); + break; + case GLYPHLESS_GLYPH: + if (s->for_overlaps) + s->background_filled_p = 1; + else + haiku_maybe_draw_background (s, 1); + haiku_draw_glyphless_glyph_string_foreground (s); + break; + } + + if (!box_filled_p && face->box != FACE_NO_BOX) + haiku_draw_string_box (s, 1); + + if (!s->for_overlaps) + { + uint32_t dcol; + dcol = face->foreground; + + haiku_draw_text_decoration (s, face, dcol, s->width, s->x); + + if (s->prev) + { + struct glyph_string *prev; + + for (prev = s->prev; prev; prev = prev->prev) + if (prev->hl != s->hl + && prev->x + prev->width + prev->right_overhang > s->x) + { + /* As prev was drawn while clipped to its own area, we + must draw the right_overhang part using s->hl now. */ + enum draw_glyphs_face save = prev->hl; + struct face *save_face = prev->face; + + prev->hl = s->hl; + prev->face = s->face; + haiku_start_clip (s); + haiku_clip_to_string_exactly (s, prev); + if (prev->first_glyph->type == CHAR_GLYPH) + haiku_draw_glyph_string_foreground (prev); + else + haiku_draw_composite_glyph_string_foreground (prev); + haiku_end_clip (s); + prev->hl = save; + prev->face = save_face; + prev->num_clips = 0; + } + } + + if (s->next) + { + struct glyph_string *next; + + for (next = s->next; next; next = next->next) + if (next->hl != s->hl + && next->x - next->left_overhang < s->x + s->width) + { + /* As next will be drawn while clipped to its own area, + we must draw the left_overhang part using s->hl now. */ + enum draw_glyphs_face save = next->hl; + struct face *save_face = next->face; + + next->hl = s->hl; + next->face = s->face; + haiku_start_clip (s); + haiku_clip_to_string_exactly (s, next); + if (next->first_glyph->type == CHAR_GLYPH) + haiku_draw_glyph_string_foreground (next); + else + haiku_draw_composite_glyph_string_foreground (next); + haiku_end_clip (s); + + next->background_filled_p = 0; + next->hl = save; + next->face = save_face; + next->clip_head = next; + next->num_clips = 0; + } + } + } + s->num_clips = 0; + haiku_end_clip (s); + unblock_input (); +} + +static void +haiku_after_update_window_line (struct window *w, + struct glyph_row *desired_row) +{ + eassert (w); + struct frame *f; + int width, height; + + if (!desired_row->mode_line_p && !w->pseudo_window_p) + desired_row->redraw_fringe_bitmaps_p = true; + + if (windows_or_buffers_changed + && desired_row->full_width_p + && (f = XFRAME (w->frame), + width = FRAME_INTERNAL_BORDER_WIDTH (f), + width != 0) + && (height = desired_row->visible_height, + height > 0)) + { + int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y)); + int face_id = + !NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID; + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); + + block_input (); + if (face) + { + void *view = FRAME_HAIKU_VIEW (f); + BView_draw_lock (view); + BView_StartClip (view); + BView_SetHighColor (view, face->background_defaulted_p ? + FRAME_BACKGROUND_PIXEL (f) : face->background); + BView_FillRectangle (view, 0, y, width, height); + BView_FillRectangle (view, FRAME_PIXEL_WIDTH (f) - width, + y, width, height); + BView_EndClip (view); + BView_draw_unlock (view); + } + else + { + haiku_clear_frame_area (f, 0, y, width, height); + haiku_clear_frame_area (f, FRAME_PIXEL_WIDTH (f) - width, + y, width, height); + } + unblock_input (); + } +} + +static void +haiku_set_window_size (struct frame *f, bool change_gravity, + int width, int height) +{ + haiku_update_size_hints (f); + + if (FRAME_HAIKU_WINDOW (f)) + { + block_input (); + BWindow_resize (FRAME_HAIKU_WINDOW (f), width, height); + unblock_input (); + } +} + +static void +haiku_draw_window_cursor (struct window *w, + struct glyph_row *glyph_row, + int x, int y, + enum text_cursor_kinds cursor_type, + int cursor_width, bool on_p, bool active_p) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + + struct glyph *phys_cursor_glyph; + struct glyph *cursor_glyph; + + void *view = FRAME_HAIKU_VIEW (f); + + int fx, fy, h, cursor_height; + + if (!on_p) + return; + + if (cursor_type == NO_CURSOR) + { + w->phys_cursor_width = 0; + return; + } + + w->phys_cursor_on_p = true; + w->phys_cursor_type = cursor_type; + + phys_cursor_glyph = get_phys_cursor_glyph (w); + + if (!phys_cursor_glyph) + { + if (glyph_row->exact_window_width_line_p + && w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA]) + { + glyph_row->cursor_in_fringe_p = 1; + draw_fringe_bitmap (w, glyph_row, 0); + } + return; + } + + get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h); + + if (cursor_type == BAR_CURSOR) + { + if (cursor_width < 1) + cursor_width = max (FRAME_CURSOR_WIDTH (f), 1); + if (cursor_width < w->phys_cursor_width) + w->phys_cursor_width = cursor_width; + } + else if (cursor_type == HBAR_CURSOR) + { + cursor_height = (cursor_width < 1) ? lrint (0.25 * h) : cursor_width; + if (cursor_height > glyph_row->height) + cursor_height = glyph_row->height; + if (h > cursor_height) + fy += h - cursor_height; + h = cursor_height; + } + + BView_draw_lock (view); + BView_StartClip (view); + BView_SetHighColor (view, FRAME_CURSOR_COLOR (f).pixel); + haiku_clip_to_row (w, glyph_row, TEXT_AREA); + + switch (cursor_type) + { + default: + case DEFAULT_CURSOR: + case NO_CURSOR: + break; + case HBAR_CURSOR: + BView_FillRectangle (view, fx, fy, w->phys_cursor_width, h); + break; + case BAR_CURSOR: + cursor_glyph = get_phys_cursor_glyph (w); + if (cursor_glyph->resolved_level & 1) + BView_FillRectangle (view, fx + cursor_glyph->pixel_width - w->phys_cursor_width, + fy, w->phys_cursor_width, h); + else + BView_FillRectangle (view, fx, fy, w->phys_cursor_width, h); + break; + case HOLLOW_BOX_CURSOR: + if (phys_cursor_glyph->type != IMAGE_GLYPH) + { + BView_SetPenSize (view, 1); + BView_StrokeRectangle (view, fx, fy, w->phys_cursor_width, h); + } + else + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + break; + case FILLED_BOX_CURSOR: + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + } + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_show_hourglass (struct frame *f) +{ + if (FRAME_OUTPUT_DATA (f)->hourglass_p) + return; + + block_input (); + FRAME_OUTPUT_DATA (f)->hourglass_p = 1; + + if (FRAME_HAIKU_VIEW (f)) + BView_set_view_cursor (FRAME_HAIKU_VIEW (f), + FRAME_OUTPUT_DATA (f)->hourglass_cursor); + unblock_input (); +} + +static void +haiku_hide_hourglass (struct frame *f) +{ + if (!FRAME_OUTPUT_DATA (f)->hourglass_p) + return; + + block_input (); + FRAME_OUTPUT_DATA (f)->hourglass_p = 0; + + if (FRAME_HAIKU_VIEW (f)) + BView_set_view_cursor (FRAME_HAIKU_VIEW (f), + FRAME_OUTPUT_DATA (f)->current_cursor); + unblock_input (); +} + +static void +haiku_compute_glyph_string_overhangs (struct glyph_string *s) +{ + if (s->cmp == NULL + && (s->first_glyph->type == CHAR_GLYPH + || s->first_glyph->type == COMPOSITE_GLYPH)) + { + struct font_metrics metrics; + + if (s->first_glyph->type == CHAR_GLYPH) + { + struct font *font = s->font; + font->driver->text_extents (font, s->char2b, s->nchars, &metrics); + } + else + { + Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); + + composition_gstring_width (gstring, s->cmp_from, s->cmp_to, &metrics); + } + s->right_overhang = (metrics.rbearing > metrics.width + ? metrics.rbearing - metrics.width : 0); + s->left_overhang = metrics.lbearing < 0 ? - metrics.lbearing : 0; + } + else if (s->cmp) + { + s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width; + s->left_overhang = - s->cmp->lbearing; + } +} + +static void +haiku_draw_vertical_window_border (struct window *w, + int x, int y_0, int y_1) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct face *face; + + face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); + void *view = FRAME_HAIKU_VIEW (f); + BView_draw_lock (view); + BView_StartClip (view); + if (face) + BView_SetHighColor (view, face->foreground); + BView_StrokeLine (view, x, y_0, x, y_1); + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_set_scroll_bar_default_width (struct frame *f) +{ + int unit = FRAME_COLUMN_WIDTH (f); + FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = BScrollBar_default_size (0) + 1; + FRAME_CONFIG_SCROLL_BAR_COLS (f) = + (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + unit - 1) / unit; +} + +static void +haiku_set_scroll_bar_default_height (struct frame *f) +{ + int height = FRAME_LINE_HEIGHT (f); + FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = BScrollBar_default_size (1) + 1; + FRAME_CONFIG_SCROLL_BAR_LINES (f) = + (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) + height - 1) / height; +} + +static void +haiku_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct face *face = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FACE_ID); + struct face *face_first + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID); + struct face *face_last + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); + unsigned long color = face ? face->foreground : FRAME_FOREGROUND_PIXEL (f); + unsigned long color_first = (face_first + ? face_first->foreground + : FRAME_FOREGROUND_PIXEL (f)); + unsigned long color_last = (face_last + ? face_last->foreground + : FRAME_FOREGROUND_PIXEL (f)); + void *view = FRAME_HAIKU_VIEW (f); + + BView_draw_lock (view); + BView_StartClip (view); + + if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3)) + /* A vertical divider, at least three pixels wide: Draw first and + last pixels differently. */ + { + BView_SetHighColor (view, color_first); + BView_StrokeLine (view, x0, y0, x0, y1 - 1); + BView_SetHighColor (view, color); + BView_FillRectangle (view, x0 + 1, y0, x1 - x0 - 2, y1 - y0); + BView_SetHighColor (view, color_last); + BView_StrokeLine (view, x1 - 1, y0, x1 - 1, y1 - 1); + } + else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) + /* A horizontal divider, at least three pixels high: Draw first and + last pixels differently. */ + { + BView_SetHighColor (view, color_first); + BView_StrokeLine (f, x0, y0, x1 - 1, y0); + BView_SetHighColor (view, color); + BView_FillRectangle (view, x0, y0 + 1, x1 - x0, y1 - y0 - 2); + BView_SetHighColor (view, color_last); + BView_StrokeLine (view, x0, y1, x1 - 1, y1); + } + else + { + BView_SetHighColor (view, color); + BView_FillRectangleAbs (view, x0, y0, x1, y1); + } + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_condemn_scroll_bars (struct frame *frame) +{ + if (!NILP (FRAME_SCROLL_BARS (frame))) + { + if (!NILP (FRAME_CONDEMNED_SCROLL_BARS (frame))) + { + /* Prepend scrollbars to already condemned ones. */ + Lisp_Object last = FRAME_SCROLL_BARS (frame); + + while (!NILP (XSCROLL_BAR (last)->next)) + last = XSCROLL_BAR (last)->next; + + XSCROLL_BAR (last)->next = FRAME_CONDEMNED_SCROLL_BARS (frame); + XSCROLL_BAR (FRAME_CONDEMNED_SCROLL_BARS (frame))->prev = last; + } + + fset_condemned_scroll_bars (frame, FRAME_SCROLL_BARS (frame)); + fset_scroll_bars (frame, Qnil); + } +} + +static void +haiku_redeem_scroll_bar (struct window *w) +{ + struct scroll_bar *bar; + Lisp_Object barobj; + struct frame *f; + + if (!NILP (w->vertical_scroll_bar) && WINDOW_HAS_VERTICAL_SCROLL_BAR (w)) + { + bar = XSCROLL_BAR (w->vertical_scroll_bar); + /* Unlink it from the condemned list. */ + f = XFRAME (WINDOW_FRAME (w)); + if (NILP (bar->prev)) + { + /* If the prev pointer is nil, it must be the first in one of + the lists. */ + if (EQ (FRAME_SCROLL_BARS (f), w->vertical_scroll_bar)) + /* It's not condemned. Everything's fine. */ + goto horizontal; + else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f), + w->vertical_scroll_bar)) + fset_condemned_scroll_bars (f, bar->next); + else + /* If its prev pointer is nil, it must be at the front of + one or the other! */ + emacs_abort (); + } + else + XSCROLL_BAR (bar->prev)->next = bar->next; + + if (! NILP (bar->next)) + XSCROLL_BAR (bar->next)->prev = bar->prev; + + bar->next = FRAME_SCROLL_BARS (f); + bar->prev = Qnil; + XSETVECTOR (barobj, bar); + fset_scroll_bars (f, barobj); + if (! NILP (bar->next)) + XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar); + } + horizontal: + if (!NILP (w->horizontal_scroll_bar) && WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w)) + { + bar = XSCROLL_BAR (w->horizontal_scroll_bar); + /* Unlink it from the condemned list. */ + f = XFRAME (WINDOW_FRAME (w)); + if (NILP (bar->prev)) + { + /* If the prev pointer is nil, it must be the first in one of + the lists. */ + if (EQ (FRAME_SCROLL_BARS (f), w->horizontal_scroll_bar)) + /* It's not condemned. Everything's fine. */ + return; + else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f), + w->horizontal_scroll_bar)) + fset_condemned_scroll_bars (f, bar->next); + else + /* If its prev pointer is nil, it must be at the front of + one or the other! */ + emacs_abort (); + } + else + XSCROLL_BAR (bar->prev)->next = bar->next; + + if (! NILP (bar->next)) + XSCROLL_BAR (bar->next)->prev = bar->prev; + + bar->next = FRAME_SCROLL_BARS (f); + bar->prev = Qnil; + XSETVECTOR (barobj, bar); + fset_scroll_bars (f, barobj); + if (! NILP (bar->next)) + XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar); + } +} + +static void +haiku_judge_scroll_bars (struct frame *f) +{ + Lisp_Object bar, next; + + bar = FRAME_CONDEMNED_SCROLL_BARS (f); + + /* Clear out the condemned list now so we won't try to process any + more events on the hapless scroll bars. */ + fset_condemned_scroll_bars (f, Qnil); + + for (; ! NILP (bar); bar = next) + { + struct scroll_bar *b = XSCROLL_BAR (bar); + + haiku_scroll_bar_remove (b); + + next = b->next; + b->next = b->prev = Qnil; + } + + /* Now there should be no references to the condemned scroll bars, + and they should get garbage-collected. */ +} + +static struct scroll_bar * +haiku_scroll_bar_create (struct window *w, int left, int top, + int width, int height, bool horizontal_p) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + Lisp_Object barobj; + + void *sb = NULL; + void *vw = FRAME_HAIKU_VIEW (f); + + block_input (); + struct scroll_bar *bar + = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, prev, PVEC_OTHER); + + XSETWINDOW (bar->window, w); + bar->top = top; + bar->left = left; + bar->width = width; + bar->height = height; + bar->position = 0; + bar->total = 0; + bar->dragging = 0; + bar->update = -1; + bar->horizontal = horizontal_p; + + sb = BScrollBar_make_for_view (vw, horizontal_p, + left, top, left + width - 1, + top + height - 1, bar); + + BView_publish_scroll_bar (vw, left, top, width, height); + + bar->next = FRAME_SCROLL_BARS (f); + bar->prev = Qnil; + bar->scroll_bar = sb; + XSETVECTOR (barobj, bar); + fset_scroll_bars (f, barobj); + + if (!NILP (bar->next)) + XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar); + + unblock_input (); + return bar; +} + +static void +haiku_set_horizontal_scroll_bar (struct window *w, int portion, int whole, int position) +{ + eassert (WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w)); + Lisp_Object barobj; + struct scroll_bar *bar; + int top, height, left, width; + int window_x, window_width; + + /* Get window dimensions. */ + window_box (w, ANY_AREA, &window_x, 0, &window_width, 0); + left = window_x; + width = window_width; + top = WINDOW_SCROLL_BAR_AREA_Y (w); + height = WINDOW_CONFIG_SCROLL_BAR_HEIGHT (w); + + block_input (); + + if (NILP (w->horizontal_scroll_bar)) + { + bar = haiku_scroll_bar_create (w, left, top, width, height, true); + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + bar->update = position; + bar->position = position; + bar->total = whole; + } + else + { + bar = XSCROLL_BAR (w->horizontal_scroll_bar); + + if (bar->left != left || bar->top != top || + bar->width != width || bar->height != height) + { + void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (w)); + BView_forget_scroll_bar (view, bar->left, bar->top, + bar->width, bar->height); + BView_move_frame (bar->scroll_bar, left, top, + left + width - 1, top + height - 1); + BView_publish_scroll_bar (view, left, top, width, height); + bar->left = left; + bar->top = top; + bar->width = width; + bar->height = height; + } + + if (!bar->dragging) + { + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + BView_invalidate (bar->scroll_bar); + } + } + bar->position = position; + bar->total = whole; + XSETVECTOR (barobj, bar); + wset_horizontal_scroll_bar (w, barobj); + unblock_input (); +} + +static void +haiku_set_vertical_scroll_bar (struct window *w, + int portion, int whole, int position) +{ + eassert (WINDOW_HAS_VERTICAL_SCROLL_BAR (w)); + Lisp_Object barobj; + struct scroll_bar *bar; + int top, height, left, width; + int window_y, window_height; + + /* Get window dimensions. */ + window_box (w, ANY_AREA, 0, &window_y, 0, &window_height); + top = window_y; + height = window_height; + + /* Compute the left edge and the width of the scroll bar area. */ + left = WINDOW_SCROLL_BAR_AREA_X (w); + width = WINDOW_SCROLL_BAR_AREA_WIDTH (w); + block_input (); + + if (NILP (w->vertical_scroll_bar)) + { + bar = haiku_scroll_bar_create (w, left, top, width, height, false); + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + bar->position = position; + bar->total = whole; + } + else + { + bar = XSCROLL_BAR (w->vertical_scroll_bar); + + if (bar->left != left || bar->top != top || + bar->width != width || bar->height != height) + { + void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (w)); + BView_forget_scroll_bar (view, bar->left, bar->top, + bar->width, bar->height); + BView_move_frame (bar->scroll_bar, left, top, + left + width - 1, top + height - 1); + flush_frame (WINDOW_XFRAME (w)); + BView_publish_scroll_bar (view, left, top, width, height); + bar->left = left; + bar->top = top; + bar->width = width; + bar->height = height; + } + + if (!bar->dragging) + { + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + bar->update = position; + BView_invalidate (bar->scroll_bar); + } + } + + bar->position = position; + bar->total = whole; + + XSETVECTOR (barobj, bar); + wset_vertical_scroll_bar (w, barobj); + unblock_input (); +} + +static void +haiku_draw_fringe_bitmap (struct window *w, struct glyph_row *row, + struct draw_fringe_bitmap_params *p) +{ + void *view = FRAME_HAIKU_VIEW (XFRAME (WINDOW_FRAME (w))); + struct face *face = p->face; + + BView_draw_lock (view); + BView_StartClip (view); + + haiku_clip_to_row (w, row, ANY_AREA); + if (p->bx >= 0 && !p->overlay_p) + { + BView_SetHighColor (view, face->background); + BView_FillRectangle (view, p->bx, p->by, p->nx, p->ny); + } + + if (p->which && p->which < fringe_bitmap_fillptr) + { + void *bitmap = fringe_bmps[p->which]; + + uint32_t col; + + if (!p->cursor_p) + col = face->foreground; + else if (p->overlay_p) + col = face->background; + else + col = FRAME_CURSOR_COLOR (XFRAME (WINDOW_FRAME (w))).pixel; + + if (!p->overlay_p) + { + BView_SetHighColor (view, face->background); + BView_FillRectangle (view, p->x, p->y, p->wd, p->h); + } + + BView_SetLowColor (view, col); + BView_DrawBitmapWithEraseOp (view, bitmap, p->x, p->y, p->wd, p->h); + } + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_define_fringe_bitmap (int which, unsigned short *bits, + int h, int wd) +{ + if (which >= fringe_bitmap_fillptr) + { + int i = fringe_bitmap_fillptr; + fringe_bitmap_fillptr = which + 20; + fringe_bmps = !i ? xmalloc (fringe_bitmap_fillptr * sizeof (void *)) : + xrealloc (fringe_bmps, fringe_bitmap_fillptr * sizeof (void *)); + + while (i < fringe_bitmap_fillptr) + fringe_bmps[i++] = NULL; + } + + fringe_bmps[which] = BBitmap_new (wd, h, 1); + BBitmap_import_mono_bits (fringe_bmps[which], bits, wd, h); +} + +static void +haiku_destroy_fringe_bitmap (int which) +{ + if (which >= fringe_bitmap_fillptr) + return; + + if (fringe_bmps[which]) + BBitmap_free (fringe_bmps[which]); + fringe_bmps[which] = NULL; +} + +static void +haiku_scroll_run (struct window *w, struct run *run) +{ + struct frame *f = XFRAME (w->frame); + void *view = FRAME_HAIKU_VIEW (f); + int x, y, width, height, from_y, to_y, bottom_y; + window_box (w, ANY_AREA, &x, &y, &width, &height); + + from_y = WINDOW_TO_FRAME_PIXEL_Y (w, run->current_y); + to_y = WINDOW_TO_FRAME_PIXEL_Y (w, run->desired_y); + bottom_y = y + height; + + if (to_y < from_y) + { + /* Scrolling up. Make sure we don't copy part of the mode + line at the bottom. */ + if (from_y + run->height > bottom_y) + height = bottom_y - from_y; + else + height = run->height; + } + else + { + /* Scrolling down. Make sure we don't copy over the mode line. + at the bottom. */ + if (to_y + run->height > bottom_y) + height = bottom_y - to_y; + else + height = run->height; + } + + if (!height) + return; + + block_input (); + gui_clear_cursor (w); + BView_draw_lock (view); +#ifdef USE_BE_CAIRO + if (EmacsView_double_buffered_p (view)) + { +#endif + BView_StartClip (view); + BView_CopyBits (view, x, from_y, width, height, + x, to_y, width, height); + BView_EndClip (view); +#ifdef USE_BE_CAIRO + } + else + { + EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + cairo_surface_t *surface = FRAME_CR_SURFACE (f); + cairo_surface_t *s + = cairo_surface_create_similar (surface, + cairo_surface_get_content (surface), + width, height); + cairo_t *cr = cairo_create (s); + if (surface) + { + cairo_set_source_surface (cr, surface, -x, -from_y); + cairo_paint (cr); + cairo_destroy (cr); + + cr = haiku_begin_cr_clip (f, NULL); + cairo_save (cr); + cairo_set_source_surface (cr, s, x, to_y); + cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE); + cairo_rectangle (cr, x, to_y, width, height); + cairo_fill (cr); + cairo_restore (cr); + cairo_surface_destroy (s); + haiku_end_cr_clip (cr); + } + EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + } +#endif + BView_draw_unlock (view); + + unblock_input (); +} + +static void +haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, + enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y, + Time *timestamp) +{ + if (!fp) + return; + + block_input (); + Lisp_Object frame, tail; + struct frame *f1 = NULL; + FOR_EACH_FRAME (tail, frame) + XFRAME (frame)->mouse_moved = false; + + if (gui_mouse_grabbed (x_display_list) && !EQ (track_mouse, Qdropping)) + f1 = x_display_list->last_mouse_frame; + + if (!f1 || FRAME_TOOLTIP_P (f1)) + f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (x_display_list)) + ? x_display_list->last_mouse_frame + : NULL); + + if (!f1 && insist > 0) + f1 = SELECTED_FRAME (); + + if (!f1 || (!FRAME_HAIKU_P (f1) && (insist > 0))) + FOR_EACH_FRAME (tail, frame) + if (FRAME_HAIKU_P (XFRAME (frame)) && + !FRAME_TOOLTIP_P (XFRAME (frame))) + f1 = XFRAME (frame); + + if (FRAME_TOOLTIP_P (f1)) + f1 = NULL; + + if (f1 && FRAME_HAIKU_P (f1)) + { + int sx, sy; + void *view = FRAME_HAIKU_VIEW (f1); + if (view) + { + BView_get_mouse (view, &sx, &sy); + + remember_mouse_glyph (f1, sx, sy, &x_display_list->last_mouse_glyph); + x_display_list->last_mouse_glyph_frame = f1; + + *bar_window = Qnil; + *part = scroll_bar_above_handle; + *fp = f1; + *timestamp = x_display_list->last_mouse_movement_time; + XSETINT (*x, sx); + XSETINT (*y, sy); + } + } + + unblock_input (); +} + +static void +haiku_flush (struct frame *f) +{ + if (FRAME_VISIBLE_P (f)) + BWindow_Flush (FRAME_HAIKU_WINDOW (f)); +} + +static void +haiku_define_frame_cursor (struct frame *f, Emacs_Cursor cursor) +{ + if (f->tooltip) + return; + block_input (); + if (!f->pointer_invisible && FRAME_HAIKU_VIEW (f) + && !FRAME_OUTPUT_DATA (f)->hourglass_p) + BView_set_view_cursor (FRAME_HAIKU_VIEW (f), cursor); + unblock_input (); + FRAME_OUTPUT_DATA (f)->current_cursor = cursor; +} + +static void +haiku_update_window_end (struct window *w, bool cursor_on_p, + bool mouse_face_overwritten_p) +{ + +} + +static void +haiku_default_font_parameter (struct frame *f, Lisp_Object parms) +{ + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + Lisp_Object font_param = gui_display_get_arg (dpyinfo, parms, Qfont, NULL, NULL, + RES_TYPE_STRING); + Lisp_Object font = Qnil; + if (EQ (font_param, Qunbound)) + font_param = Qnil; + + if (NILP (font_param)) + { + /* System font should take precedence over X resources. We suggest this + regardless of font-use-system-font because .emacs may not have been + read yet. */ + struct haiku_font_pattern ptn; + ptn.specified = 0; + + if (f->tooltip) + BFont_populate_plain_family (&ptn); + else + BFont_populate_fixed_family (&ptn); + + if (ptn.specified & FSPEC_FAMILY) + font = font_open_by_name (f, build_unibyte_string (ptn.family)); + } + + if (NILP (font)) + font = !NILP (font_param) ? font_param + : gui_display_get_arg (dpyinfo, parms, Qfont, "font", "Font", + RES_TYPE_STRING); + + if (! FONTP (font) && ! STRINGP (font)) + { + const char **names = (const char *[]) { "monospace-12", + "Noto Sans Mono-12", + "Source Code Pro-12", + NULL }; + int i; + + for (i = 0; names[i]; i++) + { + font + = font_open_by_name (f, build_unibyte_string (names[i])); + if (!NILP (font)) + break; + } + if (NILP (font)) + error ("No suitable font was found"); + } + else if (!NILP (font_param)) + { + /* Remember the explicit font parameter, so we can re-apply it + after we've applied the `default' face settings. */ + AUTO_FRAME_ARG (arg, Qfont_parameter, font_param); + gui_set_frame_parameters (f, arg); + } + + gui_default_parameter (f, parms, Qfont, font, "font", "Font", + RES_TYPE_STRING); +} + +static struct redisplay_interface haiku_redisplay_interface = + { + haiku_frame_parm_handlers, + gui_produce_glyphs, + gui_write_glyphs, + gui_insert_glyphs, + gui_clear_end_of_line, + haiku_scroll_run, + haiku_after_update_window_line, + NULL, + haiku_update_window_end, + haiku_flush, + gui_clear_window_mouse_face, + gui_get_glyph_overhangs, + gui_fix_overlapping_area, + haiku_draw_fringe_bitmap, + haiku_define_fringe_bitmap, + haiku_destroy_fringe_bitmap, + haiku_compute_glyph_string_overhangs, + haiku_draw_glyph_string, + haiku_define_frame_cursor, + haiku_clear_frame_area, + haiku_clear_under_internal_border, + haiku_draw_window_cursor, + haiku_draw_vertical_window_border, + haiku_draw_window_divider, + 0, /* shift glyphs for insert */ + haiku_show_hourglass, + haiku_hide_hourglass, + haiku_default_font_parameter, + }; + +static void +haiku_make_fullscreen_consistent (struct frame *f) +{ + Lisp_Object lval = get_frame_param (f, Qfullscreen); + + if (!EQ (lval, Qmaximized) && FRAME_OUTPUT_DATA (f)->zoomed_p) + lval = Qmaximized; + else if (EQ (lval, Qmaximized) && !FRAME_OUTPUT_DATA (f)->zoomed_p) + lval = Qnil; + + store_frame_param (f, Qfullscreen, lval); +} + +static int +haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) +{ + block_input (); + int message_count = 0; + static void *buf = NULL; + ssize_t b_size; + struct unhandled_event *unhandled_events = NULL; + int button_or_motion_p; + + if (!buf) + buf = xmalloc (200); + haiku_read_size (&b_size); + while (b_size >= 0) + { + enum haiku_event_type type; + struct input_event inev, inev2; + + if (b_size > 200) + emacs_abort (); + + EVENT_INIT (inev); + EVENT_INIT (inev2); + inev.kind = NO_EVENT; + inev2.kind = NO_EVENT; + inev.arg = Qnil; + inev2.arg = Qnil; + + button_or_motion_p = 0; + + haiku_read (&type, buf, b_size); + + switch (type) + { + case QUIT_REQUESTED: + { + struct haiku_quit_requested_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + inev.kind = DELETE_WINDOW_EVENT; + XSETFRAME (inev.frame_or_window, f); + break; + } + case FRAME_RESIZED: + { + struct haiku_resize_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + int width = lrint (b->px_widthf); + int height = lrint (b->px_heightf); + + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + BView_resize_to (FRAME_HAIKU_VIEW (f), width, height); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + if (width != FRAME_PIXEL_WIDTH (f) + || height != FRAME_PIXEL_HEIGHT (f) + || (f->new_size_p + && ((f->new_width >= 0 && width != f->new_width) + || (f->new_height >= 0 && height != f->new_height)))) + { + change_frame_size (f, width, height, false, true, false); + SET_FRAME_GARBAGED (f); + cancel_mouse_face (f); + haiku_clear_under_internal_border (f); + } + + if (FRAME_OUTPUT_DATA (f)->pending_zoom_width != width || + FRAME_OUTPUT_DATA (f)->pending_zoom_height != height) + { + FRAME_OUTPUT_DATA (f)->zoomed_p = 0; + haiku_make_fullscreen_consistent (f); + } + else + { + FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + FRAME_OUTPUT_DATA (f)->pending_zoom_width = INT_MIN; + FRAME_OUTPUT_DATA (f)->pending_zoom_height = INT_MIN; + } + break; + } + case FRAME_EXPOSED: + { + struct haiku_expose_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + expose_frame (f, b->x, b->y, b->width, b->height); + + haiku_clear_under_internal_border (f); + break; + } + case KEY_DOWN: + { + struct haiku_key_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + int non_ascii_p; + if (!f) + continue; + + inev.code = b->unraw_mb_char; + + BMapKey (b->kc, &non_ascii_p, &inev.code); + + if (non_ascii_p) + inev.kind = NON_ASCII_KEYSTROKE_EVENT; + else + inev.kind = inev.code > 127 ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : + ASCII_KEYSTROKE_EVENT; + + inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); + XSETFRAME (inev.frame_or_window, f); + break; + } + case ACTIVATION: + { + struct haiku_activation_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + if ((x_display_list->focus_event_frame != f && b->activated_p) || + (x_display_list->focus_event_frame == f && !b->activated_p)) + { + haiku_new_focus_frame (b->activated_p ? f : NULL); + if (b->activated_p) + x_display_list->focus_event_frame = f; + else + x_display_list->focus_event_frame = NULL; + inev.kind = b->activated_p ? FOCUS_IN_EVENT : FOCUS_OUT_EVENT; + XSETFRAME (inev.frame_or_window, f); + } + + break; + } + case MOUSE_MOTION: + { + struct haiku_mouse_motion_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + Lisp_Object frame; + XSETFRAME (frame, f); + + x_display_list->last_mouse_movement_time = time (NULL); + button_or_motion_p = 1; + + if (b->just_exited_p) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); + if (f == hlinfo->mouse_face_mouse_frame) + { + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = 0; + } + + haiku_new_focus_frame (x_display_list->focused_frame); + help_echo_string = Qnil; + gen_help_event (Qnil, frame, Qnil, Qnil, 0); + } + else + { + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + struct haiku_rect r = dpyinfo->last_mouse_glyph; + + dpyinfo->last_mouse_motion_x = b->x; + dpyinfo->last_mouse_motion_y = b->y; + dpyinfo->last_mouse_motion_frame = f; + + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + if (f != dpyinfo->last_mouse_glyph_frame + || b->x < r.x || b->x >= r.x + r.width + || b->y < r.y || b->y >= r.y + r.height) + { + f->mouse_moved = true; + dpyinfo->last_mouse_scroll_bar = NULL; + note_mouse_highlight (f, b->x, b->y); + remember_mouse_glyph (f, b->x, b->y, + &FRAME_DISPLAY_INFO (f)->last_mouse_glyph); + dpyinfo->last_mouse_glyph_frame = f; + gen_help_event (help_echo_string, frame, help_echo_window, + help_echo_object, help_echo_pos); + } + + if (MOUSE_HL_INFO (f)->mouse_face_hidden) + { + MOUSE_HL_INFO (f)->mouse_face_hidden = 0; + clear_mouse_face (MOUSE_HL_INFO (f)); + } + + if (!NILP (Vmouse_autoselect_window)) + { + static Lisp_Object last_mouse_window; + Lisp_Object window = window_from_coordinates (f, b->x, b->y, 0, 0, 0); + + if (WINDOWP (window) + && !EQ (window, last_mouse_window) + && !EQ (window, selected_window) + && (!NILP (focus_follows_mouse) + || (EQ (XWINDOW (window)->frame, + XWINDOW (selected_window)->frame)))) + { + inev.kind = SELECT_WINDOW_EVENT; + inev.frame_or_window = window; + } + + last_mouse_window = window; + } + } + break; + } + case BUTTON_UP: + case BUTTON_DOWN: + { + struct haiku_button_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + Lisp_Object tab_bar_arg = Qnil; + int tab_bar_p = 0, tool_bar_p = 0; + + if (!f) + continue; + + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + + inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); + + x_display_list->last_mouse_glyph_frame = 0; + x_display_list->last_mouse_movement_time = time (NULL); + button_or_motion_p = 1; + + /* Is this in the tab-bar? */ + if (WINDOWP (f->tab_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) + { + Lisp_Object window; + int x = b->x; + int y = b->y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tab_bar_p = EQ (window, f->tab_bar_window); + + if (tab_bar_p) + tab_bar_arg = handle_tab_bar_click + (f, x, y, type == BUTTON_DOWN, inev.modifiers); + } + + if (WINDOWP (f->tool_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) + { + Lisp_Object window; + int x = b->x; + int y = b->y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tool_bar_p = EQ (window, f->tool_bar_window); + + if (tool_bar_p) + { + handle_tool_bar_click + (f, x, y, type == BUTTON_DOWN, inev.modifiers); + redisplay (); + } + } + + if (type == BUTTON_UP) + { + inev.modifiers |= up_modifier; + dpyinfo->grabbed &= ~(1 << b->btn_no); + } + else + { + inev.modifiers |= down_modifier; + dpyinfo->last_mouse_frame = f; + dpyinfo->grabbed |= (1 << b->btn_no); + if (f && !tab_bar_p) + f->last_tab_bar_item = -1; + if (f && !tool_bar_p) + f->last_tool_bar_item = -1; + } + + if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) + inev.kind = MOUSE_CLICK_EVENT; + inev.arg = tab_bar_arg; + inev.code = b->btn_no; + + f->mouse_moved = false; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + + XSETFRAME (inev.frame_or_window, f); + break; + } + case ICONIFICATION: + { + struct haiku_iconification_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + if (!b->iconified_p) + { + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, 0); + inev.kind = DEICONIFY_EVENT; + + + /* Haiku doesn't expose frames on deiconification, but + if we are double-buffered, the previous screen + contents should have been preserved. */ + if (!EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) + { + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } + } + else + { + SET_FRAME_VISIBLE (f, 0); + SET_FRAME_ICONIFIED (f, 1); + inev.kind = ICONIFY_EVENT; + } + + XSETFRAME (inev.frame_or_window, f); + break; + } + case MOVE_EVENT: + { + struct haiku_move_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + if (FRAME_OUTPUT_DATA (f)->pending_zoom_x != b->x || + FRAME_OUTPUT_DATA (f)->pending_zoom_y != b->y) + FRAME_OUTPUT_DATA (f)->zoomed_p = 0; + else + { + FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + FRAME_OUTPUT_DATA (f)->pending_zoom_x = INT_MIN; + FRAME_OUTPUT_DATA (f)->pending_zoom_y = INT_MIN; + } + + if (FRAME_PARENT_FRAME (f)) + haiku_coords_from_parent (f, &b->x, &b->y); + + if (b->x != f->left_pos || b->y != f->top_pos) + { + inev.kind = MOVE_FRAME_EVENT; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + + f->left_pos = b->x; + f->top_pos = b->y; + + struct frame *p; + + if ((p = FRAME_PARENT_FRAME (f))) + { + void *window = FRAME_HAIKU_WINDOW (p); + EmacsWindow_move_weak_child (window, b->window, b->x, b->y); + } + + XSETFRAME (inev.frame_or_window, f); + } + + haiku_make_fullscreen_consistent (f); + break; + } + case SCROLL_BAR_VALUE_EVENT: + { + struct haiku_scroll_bar_value_event *b = buf; + struct scroll_bar *bar = b->scroll_bar; + + struct window *w = XWINDOW (bar->window); + + if (bar->update != -1) + { + bar->update = -1; + break; + } + + if (bar->position != b->position) + { + inev.kind = bar->horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : + SCROLL_BAR_CLICK_EVENT; + inev.part = bar->horizontal ? + scroll_bar_horizontal_handle : scroll_bar_handle; + + XSETINT (inev.x, b->position); + XSETINT (inev.y, bar->total); + XSETWINDOW (inev.frame_or_window, w); + } + break; + } + case SCROLL_BAR_DRAG_EVENT: + { + struct haiku_scroll_bar_drag_event *b = buf; + struct scroll_bar *bar = b->scroll_bar; + + bar->dragging = b->dragging_p; + if (!b->dragging_p && bar->horizontal) + set_horizontal_scroll_bar (XWINDOW (bar->window)); + else if (!b->dragging_p) + set_vertical_scroll_bar (XWINDOW (bar->window)); + break; + } + case WHEEL_MOVE_EVENT: + { + struct haiku_wheel_move_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + int x, y; + static float px = 0.0f, py = 0.0f; + + if (!f) + continue; + BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y); + + inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); + + inev2.modifiers = inev.modifiers; + + if (signbit (px) != signbit (b->delta_x)) + px = 0; + + if (signbit (py) != signbit (b->delta_y)) + py = 0; + + px += (b->delta_x + * powf (FRAME_PIXEL_HEIGHT (f), 2.0f / 3.0f)); + py += (b->delta_y + * powf (FRAME_PIXEL_HEIGHT (f), 2.0f / 3.0f)); + + if (fabsf (py) >= FRAME_LINE_HEIGHT (f) + || fabsf (px) >= FRAME_COLUMN_WIDTH (f) + || !x_coalesce_scroll_events) + { + inev.kind = (fabsf (px) > fabsf (py) + ? HORIZ_WHEEL_EVENT + : WHEEL_EVENT); + inev.code = 0; + + XSETINT (inev.x, x); + XSETINT (inev.y, y); + inev.arg = list3 (Qnil, make_float (-px), + make_float (-py)); + XSETFRAME (inev.frame_or_window, f); + + inev.modifiers |= (signbit (inev.kind == HORIZ_WHEEL_EVENT + ? px : py) + ? up_modifier + : down_modifier); + py = 0.0f; + px = 0.0f; + } + + break; + } + + case MENU_BAR_RESIZE: + { + struct haiku_menu_bar_resize_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + int old_height = FRAME_MENU_BAR_HEIGHT (f); + + FRAME_MENU_BAR_HEIGHT (f) = b->height + 1; + FRAME_MENU_BAR_LINES (f) = + (b->height + FRAME_LINE_HEIGHT (f)) / FRAME_LINE_HEIGHT (f); + + if (old_height != b->height) + { + adjust_frame_size (f, -1, -1, 3, true, Qmenu_bar_lines); + haiku_clear_under_internal_border (f); + } + break; + } + case MENU_BAR_OPEN: + case MENU_BAR_CLOSE: + { + struct haiku_menu_bar_state_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + if (type == MENU_BAR_OPEN) + { + if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + { + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + /* This shouldn't be here, but nsmenu does it, so + it should probably be safe. */ + int was_waiting_for_input_p = waiting_for_input; + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, 1); + waiting_for_input = was_waiting_for_input_p; + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + } + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; + popup_activated_p += 1; + } + else + { + if (!popup_activated_p) + emacs_abort (); + if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + { + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0; + popup_activated_p -= 1; + } + } + break; + } + case MENU_BAR_SELECT_EVENT: + { + struct haiku_menu_bar_select_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + if (FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + find_and_call_menu_selection (f, f->menu_bar_items_used, + f->menu_bar_vector, b->ptr); + break; + } + case FILE_PANEL_EVENT: + { + if (!popup_activated_p) + continue; + + struct unhandled_event *ev = xmalloc (sizeof *ev); + ev->next = unhandled_events; + ev->type = type; + memcpy (&ev->buffer, buf, 200); + + unhandled_events = ev; + break; + } + case MENU_BAR_HELP_EVENT: + { + struct haiku_menu_bar_help_event *b = buf; + + if (!popup_activated_p) + continue; + + struct frame *f = haiku_window_to_frame (b->window); + if (!f || !FRAME_EXTERNAL_MENU_BAR (f) || + !FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + continue; + + run_menu_bar_help_event (f, b->mb_idx); + + break; + } + case ZOOM_EVENT: + { + struct haiku_zoom_event *b = buf; + + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + FRAME_OUTPUT_DATA (f)->pending_zoom_height = b->height; + FRAME_OUTPUT_DATA (f)->pending_zoom_width = b->width; + FRAME_OUTPUT_DATA (f)->pending_zoom_x = b->x; + FRAME_OUTPUT_DATA (f)->pending_zoom_y = b->y; + + FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + haiku_make_fullscreen_consistent (f); + break; + } + case REFS_EVENT: + { + struct haiku_refs_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + inev.kind = DRAG_N_DROP_EVENT; + inev.arg = build_string_from_utf8 (b->ref); + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + XSETFRAME (inev.frame_or_window, f); + + /* There should be no problem with calling free here. + free on Haiku is thread-safe. */ + free (b->ref); + break; + } + case APP_QUIT_REQUESTED_EVENT: + case KEY_UP: + default: + break; + } + + haiku_read_size (&b_size); + + if (inev.kind != NO_EVENT) + { + if (inev.kind != HELP_EVENT) + inev.timestamp = (button_or_motion_p + ? x_display_list->last_mouse_movement_time + : time (NULL)); + kbd_buffer_store_event_hold (&inev, hold_quit); + ++message_count; + } + + if (inev2.kind != NO_EVENT) + { + if (inev2.kind != HELP_EVENT) + inev2.timestamp = (button_or_motion_p + ? x_display_list->last_mouse_movement_time + : time (NULL)); + kbd_buffer_store_event_hold (&inev2, hold_quit); + ++message_count; + } + } + + for (struct unhandled_event *ev = unhandled_events; ev;) + { + haiku_write_without_signal (ev->type, &ev->buffer); + struct unhandled_event *old = ev; + ev = old->next; + xfree (old); + } + + unblock_input (); + return message_count; +} + +static void +haiku_frame_rehighlight (struct frame *frame) +{ + haiku_rehighlight (); +} + +static void +haiku_delete_window (struct frame *f) +{ + check_window_system (f); + haiku_free_frame_resources (f); +} + +static void +haiku_free_pixmap (struct frame *f, Emacs_Pixmap pixmap) +{ + BBitmap_free (pixmap); +} + +static void +haiku_beep (struct frame *f) +{ + if (visible_bell) + { + void *view = FRAME_HAIKU_VIEW (f); + if (view) + { + block_input (); + BView_draw_lock (view); + if (!EmacsView_double_buffered_p (view)) + { + BView_SetHighColorForVisibleBell (view, FRAME_FOREGROUND_PIXEL (f)); + BView_FillRectangleForVisibleBell (view, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } + else + { + EmacsView_do_visible_bell (view, FRAME_FOREGROUND_PIXEL (f)); + haiku_flip_buffers (f); + } + BView_draw_unlock (view); + unblock_input (); + } + } + else + haiku_ring_bell (); +} + +static void +haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p) +{ + void *view = FRAME_HAIKU_VIEW (f); + + if (view) + { + block_input (); + BView_set_view_cursor (view, invisible_p ? + FRAME_OUTPUT_DATA (f)->no_cursor : + FRAME_OUTPUT_DATA (f)->current_cursor); + f->pointer_invisible = invisible_p; + unblock_input (); + } +} + +static void +haiku_fullscreen (struct frame *f) +{ + if (f->want_fullscreen == FULLSCREEN_MAXIMIZED) + { + EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); + BWindow_zoom (FRAME_HAIKU_WINDOW (f)); + } + else if (f->want_fullscreen == FULLSCREEN_BOTH) + EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1); + else if (f->want_fullscreen == FULLSCREEN_NONE) + { + EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); + EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f)); + } + + f->want_fullscreen = FULLSCREEN_NONE; + + haiku_update_size_hints (f); +} + +static struct terminal * +haiku_create_terminal (struct haiku_display_info *dpyinfo) +{ + struct terminal *terminal; + + terminal = create_terminal (output_haiku, &haiku_redisplay_interface); + + terminal->display_info.haiku = dpyinfo; + dpyinfo->terminal = terminal; + terminal->kboard = allocate_kboard (Qhaiku); + + terminal->iconify_frame_hook = haiku_iconify_frame; + terminal->focus_frame_hook = haiku_focus_frame; + terminal->ring_bell_hook = haiku_beep; + terminal->popup_dialog_hook = haiku_popup_dialog; + terminal->frame_visible_invisible_hook = haiku_set_frame_visible_invisible; + terminal->set_frame_offset_hook = haiku_set_offset; + terminal->delete_terminal_hook = haiku_delete_terminal; + terminal->get_string_resource_hook = get_string_resource; + terminal->set_new_font_hook = haiku_new_font; + terminal->defined_color_hook = haiku_defined_color; + terminal->set_window_size_hook = haiku_set_window_size; + terminal->read_socket_hook = haiku_read_socket; + terminal->implicit_set_name_hook = haiku_implicitly_set_name; + terminal->mouse_position_hook = haiku_mouse_position; + terminal->delete_frame_hook = haiku_delete_window; + terminal->frame_up_to_date_hook = haiku_frame_up_to_date; + terminal->buffer_flipping_unblocked_hook = haiku_buffer_flipping_unblocked_hook; + terminal->clear_frame_hook = haiku_clear_frame; + terminal->change_tab_bar_height_hook = haiku_change_tab_bar_height; + terminal->change_tool_bar_height_hook = haiku_change_tool_bar_height; + terminal->set_vertical_scroll_bar_hook = haiku_set_vertical_scroll_bar; + terminal->set_horizontal_scroll_bar_hook = haiku_set_horizontal_scroll_bar; + terminal->set_scroll_bar_default_height_hook = haiku_set_scroll_bar_default_height; + terminal->set_scroll_bar_default_width_hook = haiku_set_scroll_bar_default_width; + terminal->judge_scroll_bars_hook = haiku_judge_scroll_bars; + terminal->condemn_scroll_bars_hook = haiku_condemn_scroll_bars; + terminal->redeem_scroll_bar_hook = haiku_redeem_scroll_bar; + terminal->update_begin_hook = haiku_update_begin; + terminal->update_end_hook = haiku_update_end; + terminal->frame_rehighlight_hook = haiku_frame_rehighlight; + terminal->query_frame_background_color = haiku_query_frame_background_color; + terminal->free_pixmap = haiku_free_pixmap; + terminal->frame_raise_lower_hook = haiku_frame_raise_lower; + terminal->menu_show_hook = haiku_menu_show; + terminal->toggle_invisible_pointer_hook = haiku_toggle_invisible_pointer; + terminal->fullscreen_hook = haiku_fullscreen; + + return terminal; +} + +struct haiku_display_info * +haiku_term_init (void) +{ + struct haiku_display_info *dpyinfo; + struct terminal *terminal; + + Lisp_Object color_file, color_map; + + block_input (); + Fset_input_interrupt_mode (Qnil); + + baud_rate = 19200; + + dpyinfo = xzalloc (sizeof *dpyinfo); + + haiku_io_init (); + + if (port_application_to_emacs < B_OK) + emacs_abort (); + + color_file = Fexpand_file_name (build_string ("rgb.txt"), + Fsymbol_value (intern ("data-directory"))); + + color_map = Fx_load_color_file (color_file); + if (NILP (color_map)) + fatal ("Could not read %s.\n", SDATA (color_file)); + + dpyinfo->color_map = color_map; + + dpyinfo->display = BApplication_setup (); + + BScreen_res (&dpyinfo->resx, &dpyinfo->resy); + + dpyinfo->next = x_display_list; + dpyinfo->n_planes = be_get_display_planes (); + x_display_list = dpyinfo; + + terminal = haiku_create_terminal (dpyinfo); + if (current_kboard == initial_kboard) + current_kboard = terminal->kboard; + + terminal->kboard->reference_count++; + /* Never delete haiku displays -- there can only ever be one, + anyhow. */ + terminal->reference_count++; + terminal->name = xstrdup ("be"); + + dpyinfo->name_list_element = Fcons (build_string ("be"), Qnil); + dpyinfo->smallest_font_height = 1; + dpyinfo->smallest_char_width = 1; + + gui_init_fringe (terminal->rif); + unblock_input (); + + return dpyinfo; +} + +void +put_xrm_resource (Lisp_Object name, Lisp_Object val) +{ + eassert (STRINGP (name)); + eassert (STRINGP (val) || NILP (val)); + + Lisp_Object lval = assoc_no_quit (name, rdb); + if (!NILP (lval)) + Fsetcdr (lval, val); + else + rdb = Fcons (Fcons (name, val), rdb); +} + +void +haiku_clear_under_internal_border (struct frame *f) +{ + if (FRAME_INTERNAL_BORDER_WIDTH (f) > 0) + { + int border = FRAME_INTERNAL_BORDER_WIDTH (f); + int width = FRAME_PIXEL_WIDTH (f); + int height = FRAME_PIXEL_HEIGHT (f); + int margin = FRAME_TOP_MARGIN_HEIGHT (f); + int face_id = + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); + void *view = FRAME_HAIKU_VIEW (f); + block_input (); + BView_draw_lock (view); + BView_StartClip (view); + BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + + if (face) + BView_SetHighColor (view, face->background); + else + BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f)); + + BView_FillRectangle (view, 0, margin, width, border); + BView_FillRectangle (view, 0, 0, border, height); + BView_FillRectangle (view, 0, margin, width, border); + BView_FillRectangle (view, width - border, 0, border, height); + BView_FillRectangle (view, 0, height - border, width, border); + BView_EndClip (view); + BView_draw_unlock (view); + unblock_input (); + } +} + +void +mark_haiku_display (void) +{ + if (x_display_list) + mark_object (x_display_list->color_map); +} + +void +haiku_scroll_bar_remove (struct scroll_bar *bar) +{ + block_input (); + void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (XWINDOW (bar->window))); + BView_forget_scroll_bar (view, bar->left, bar->top, bar->width, bar->height); + BScrollBar_delete (bar->scroll_bar); + expose_frame (WINDOW_XFRAME (XWINDOW (bar->window)), + bar->left, bar->top, bar->width, bar->height); + + if (bar->horizontal) + wset_horizontal_scroll_bar (XWINDOW (bar->window), Qnil); + else + wset_vertical_scroll_bar (XWINDOW (bar->window), Qnil); + + unblock_input (); +}; + +void +haiku_set_offset (struct frame *frame, int x, int y, + int change_gravity) +{ + if (change_gravity > 0) + { + frame->top_pos = y; + frame->left_pos = x; + frame->size_hint_flags &= ~ (XNegative | YNegative); + if (x < 0) + frame->size_hint_flags |= XNegative; + if (y < 0) + frame->size_hint_flags |= YNegative; + frame->win_gravity = NorthWestGravity; + } + + haiku_update_size_hints (frame); + + block_input (); + if (change_gravity) + BWindow_set_offset (FRAME_HAIKU_WINDOW (frame), x, y); + unblock_input (); +} + +#ifdef USE_BE_CAIRO +cairo_t * +haiku_begin_cr_clip (struct frame *f, struct glyph_string *s) +{ + cairo_surface_t *surface = FRAME_CR_SURFACE (f); + if (!surface) + return NULL; + + cairo_t *context = cairo_create (surface); + return context; +} + +void +haiku_end_cr_clip (cairo_t *cr) +{ + cairo_destroy (cr); +} +#endif + +void +syms_of_haikuterm (void) +{ + DEFVAR_BOOL ("haiku-initialized", haiku_initialized, + doc: /* Non-nil if the Haiku terminal backend has been initialized. */); + + DEFVAR_BOOL ("x-use-underline-position-properties", + x_use_underline_position_properties, + doc: /* SKIP: real doc in xterm.c. */); + x_use_underline_position_properties = 1; + + DEFVAR_BOOL ("x-underline-at-descent-line", + x_underline_at_descent_line, + doc: /* SKIP: real doc in xterm.c. */); + x_underline_at_descent_line = 0; + + DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars, + doc: /* SKIP: real doc in xterm.c. */); + Vx_toolkit_scroll_bars = Qt; + + DEFVAR_BOOL ("x-coalesce-scroll-events", x_coalesce_scroll_events, + doc: /* SKIP: real doc in xterm.c. */); + x_coalesce_scroll_events = true; + + DEFVAR_BOOL ("haiku-debug-on-fatal-error", haiku_debug_on_fatal_error, + doc: /* If non-nil, Emacs will launch the system debugger upon a fatal error. */); + haiku_debug_on_fatal_error = 1; + + DEFSYM (Qshift, "shift"); + DEFSYM (Qcontrol, "control"); + DEFSYM (Qoption, "option"); + DEFSYM (Qcommand, "command"); + + DEFVAR_LISP ("haiku-meta-keysym", Vhaiku_meta_keysym, + doc: /* Which key Emacs uses as the meta modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `command'. + +Setting it to any other value is equivalent to `command'. */); + Vhaiku_meta_keysym = Qnil; + + DEFVAR_LISP ("haiku-control-keysym", Vhaiku_control_keysym, + doc: /* Which key Emacs uses as the control modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `control'. + +Setting it to any other value is equivalent to `control'. */); + Vhaiku_control_keysym = Qnil; + + DEFVAR_LISP ("haiku-super-keysym", Vhaiku_super_keysym, + doc: /* Which key Emacs uses as the super modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `option'. + +Setting it to any other value is equivalent to `option'. */); + Vhaiku_super_keysym = Qnil; + + DEFVAR_LISP ("haiku-shift-keysym", Vhaiku_shift_keysym, + doc: /* Which key Emacs uses as the shift modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `shift'. + +Setting it to any other value is equivalent to `shift'. */); + Vhaiku_shift_keysym = Qnil; + + + DEFSYM (Qx_use_underline_position_properties, + "x-use-underline-position-properties"); + + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); + + rdb = Qnil; + staticpro (&rdb); + + Fprovide (Qhaiku, Qnil); +#ifdef USE_BE_CAIRO + Fprovide (intern_c_string ("cairo"), Qnil); +#endif +} diff --git a/src/haikuterm.h b/src/haikuterm.h new file mode 100644 index 00000000000..7ed7485ef53 --- /dev/null +++ b/src/haikuterm.h @@ -0,0 +1,296 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_TERM_H_ +#define _HAIKU_TERM_H_ + +#include + +#ifdef USE_BE_CAIRO +#include +#endif + +#include "haikugui.h" +#include "frame.h" +#include "character.h" +#include "dispextern.h" +#include "font.h" +#include "systime.h" + +#define C_FRAME struct frame * +#define C_FONT struct font * +#define C_TERMINAL struct terminal * + +#define HAVE_CHAR_CACHE_MAX 65535 + +extern int popup_activated_p; + +extern void be_app_quit (void); + +struct haikufont_info +{ + struct font font; + haiku be_font; + struct font_metrics **metrics; + short metrics_nrows; + + unsigned short **glyphs; +}; + +struct haiku_bitmap_record +{ + haiku img; + char *file; + int refcount; + int height, width, depth; +}; + +struct haiku_display_info +{ + /* Chain of all haiku_display_info structures. */ + struct haiku_display_info *next; + C_TERMINAL terminal; + + Lisp_Object name_list_element; + Lisp_Object color_map; + + int n_fonts; + + int smallest_char_width; + int smallest_font_height; + + struct frame *focused_frame; + struct frame *focus_event_frame; + struct frame *last_mouse_glyph_frame; + + struct haiku_bitmap_record *bitmaps; + ptrdiff_t bitmaps_size; + ptrdiff_t bitmaps_last; + + int grabbed; + int n_planes; + int color_p; + + Window root_window; + Lisp_Object rdb; + + Emacs_Cursor vertical_scroll_bar_cursor; + Emacs_Cursor horizontal_scroll_bar_cursor; + + Mouse_HLInfo mouse_highlight; + + C_FRAME highlight_frame; + C_FRAME last_mouse_frame; + C_FRAME last_mouse_motion_frame; + + int last_mouse_motion_x; + int last_mouse_motion_y; + + struct haiku_rect last_mouse_glyph; + + void *last_mouse_scroll_bar; + + haiku display; + + double resx, resy; + + Time last_mouse_movement_time; +}; + +struct haiku_output +{ + Emacs_Cursor text_cursor; + Emacs_Cursor nontext_cursor; + Emacs_Cursor modeline_cursor; + Emacs_Cursor hand_cursor; + Emacs_Cursor hourglass_cursor; + Emacs_Cursor horizontal_drag_cursor; + Emacs_Cursor vertical_drag_cursor; + Emacs_Cursor left_edge_cursor; + Emacs_Cursor top_left_corner_cursor; + Emacs_Cursor top_edge_cursor; + Emacs_Cursor top_right_corner_cursor; + Emacs_Cursor right_edge_cursor; + Emacs_Cursor bottom_right_corner_cursor; + Emacs_Cursor bottom_edge_cursor; + Emacs_Cursor bottom_left_corner_cursor; + Emacs_Cursor no_cursor; + + Emacs_Cursor current_cursor; + + struct haiku_display_info *display_info; + + int baseline_offset; + int fontset; + + Emacs_Color cursor_color; + + Window window_desc, parent_desc; + char explicit_parent; + + int titlebar_height; + int toolbar_height; + + haiku window; + haiku view; + haiku menubar; + + int menu_up_to_date_p; + int zoomed_p; + + int pending_zoom_x; + int pending_zoom_y; + int pending_zoom_width; + int pending_zoom_height; + + int menu_bar_open_p; + + C_FONT font; + + int hourglass_p; + uint32_t cursor_fg; + bool dirty_p; + + /* The pending position we're waiting for. */ + int pending_top, pending_left; +}; + +struct x_output +{ + /* Unused, makes term.c happy. */ +}; + +extern struct haiku_display_info *x_display_list; +extern struct font_driver const haikufont_driver; + +struct scroll_bar +{ + /* These fields are shared by all vectors. */ + union vectorlike_header header; + + /* The window we're a scroll bar for. */ + Lisp_Object window; + + /* The next and previous in the chain of scroll bars in this frame. */ + Lisp_Object next, prev; + + /* Fields after 'prev' are not traced by the GC. */ + + /* The position and size of the scroll bar in pixels, relative to the + frame. */ + int top, left, width, height; + + /* The actual scrollbar. */ + void *scroll_bar; + + /* Non-nil if the scroll bar handle is currently being dragged by + the user. */ + int dragging; + + /* The update position if we are waiting for a scrollbar update, or + -1. */ + int update; + + /* The last known position of this scrollbar. */ + int position; + + /* The total number of units inside this scrollbar. */ + int total; + + /* True if the scroll bar is horizontal. */ + bool horizontal; +}; + +#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec)) + +#define FRAME_DIRTY_P(f) (FRAME_OUTPUT_DATA (f)->dirty_p) +#define MAKE_FRAME_DIRTY(f) (FRAME_DIRTY_P (f) = 1) +#define FRAME_OUTPUT_DATA(f) ((f)->output_data.haiku) +#define FRAME_HAIKU_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) +#define FRAME_HAIKU_VIEW(f) ((MAKE_FRAME_DIRTY (f)), FRAME_OUTPUT_DATA (f)->view) +#define FRAME_HAIKU_MENU_BAR(f) (FRAME_OUTPUT_DATA (f)->menubar) +#define FRAME_DISPLAY_INFO(f) (FRAME_OUTPUT_DATA (f)->display_info) +#define FRAME_FONT(f) (FRAME_OUTPUT_DATA (f)->font) +#define FRAME_FONTSET(f) (FRAME_OUTPUT_DATA (f)->fontset) +#define FRAME_NATIVE_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) +#define FRAME_BASELINE_OFFSET(f) (FRAME_OUTPUT_DATA (f)->baseline_offset) +#define FRAME_CURSOR_COLOR(f) (FRAME_OUTPUT_DATA (f)->cursor_color) + +#ifdef USE_BE_CAIRO +#define FRAME_CR_SURFACE(f) \ + (FRAME_HAIKU_VIEW (f) ? EmacsView_cairo_surface (FRAME_HAIKU_VIEW (f)) : 0); +#endif + +extern void syms_of_haikuterm (void); +extern void syms_of_haikufns (void); +extern void syms_of_haikumenu (void); +extern void syms_of_haikufont (void); +extern void syms_of_haikuselect (void); +extern void init_haiku_select (void); + +extern void haiku_iconify_frame (struct frame *); +extern void haiku_visualize_frame (struct frame *); +extern void haiku_unvisualize_frame (struct frame *); +extern void haiku_set_offset (struct frame *, int, int, int); +extern void haiku_set_frame_visible_invisible (struct frame *, bool); +extern void haiku_free_frame_resources (struct frame *f); +extern void haiku_scroll_bar_remove (struct scroll_bar *bar); +extern void haiku_clear_under_internal_border (struct frame *f); +extern void haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p); + +extern struct haiku_display_info *haiku_term_init (void); + +extern void mark_haiku_display (void); + +extern int haiku_get_color (const char *name, Emacs_Color *color); +extern void haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_change_tab_bar_height (struct frame *f, int height); +extern void haiku_change_tool_bar_height (struct frame *f, int height); + +extern void haiku_query_color (uint32_t col, Emacs_Color *color); + +extern unsigned long haiku_get_pixel (haiku bitmap, int x, int y); +extern void haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel); + +extern Lisp_Object haiku_menu_show (struct frame *f, int x, int y, int menu_flags, + Lisp_Object title, const char **error_name); +extern Lisp_Object haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents); + +extern void initialize_frame_menubar (struct frame *f); + +extern void run_menu_bar_help_event (struct frame *f, int mb_idx); +extern void put_xrm_resource (Lisp_Object name, Lisp_Object val); + +#ifdef HAVE_NATIVE_IMAGE_API +extern bool haiku_can_use_native_image_api (Lisp_Object type); +extern int haiku_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data); +extern void syms_of_haikuimage (void); +#endif + +#ifdef USE_BE_CAIRO +extern cairo_t * +haiku_begin_cr_clip (struct frame *f, struct glyph_string *s); + +extern void +haiku_end_cr_clip (cairo_t *cr); +#endif +#endif /* _HAIKU_TERM_H_ */ diff --git a/src/image.c b/src/image.c index a41a2a16a64..da23b66cb5e 100644 --- a/src/image.c +++ b/src/image.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include /* Include this before including to work around bugs with @@ -150,6 +151,27 @@ typedef struct pgtk_bitmap_record Bitmap_Record; # define COLOR_TABLE_SUPPORT 1 #endif +#ifdef HAVE_HAIKU +#include "haiku_support.h" +typedef struct haiku_bitmap_record Bitmap_Record; + +#define GET_PIXEL(ximg, x, y) haiku_get_pixel (ximg, x, y) +#define PUT_PIXEL haiku_put_pixel +#define NO_PIXMAP 0 + +#define PIX_MASK_RETAIN 0 +#define PIX_MASK_DRAW 1 + +#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b)) +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) +#define RED16_FROM_ULONG(color) (RED_FROM_ULONG (color) * 0x101) +#define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG (color) * 0x101) +#define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG (color) * 0x101) + +#endif + static void image_disable_image (struct frame *, struct image *); static void image_edge_detection (struct frame *, struct image *, Lisp_Object, Lisp_Object); @@ -514,6 +536,11 @@ image_create_bitmap_from_data (struct frame *f, char *bits, } } } +#endif /* HAVE_PGTK */ + +#ifdef HAVE_HAIKU + void *bitmap = BBitmap_new (width, height, 1); + BBitmap_import_mono_bits (bitmap, bits, width, height); #endif id = image_allocate_bitmap_record (f); @@ -530,6 +557,11 @@ image_create_bitmap_from_data (struct frame *f, char *bits, image_create_pattern_from_pixbuf (f, pixbuf); #endif +#ifdef HAVE_HAIKU + dpyinfo->bitmaps[id - 1].img = bitmap; + dpyinfo->bitmaps[id - 1].depth = 1; +#endif + dpyinfo->bitmaps[id - 1].file = NULL; dpyinfo->bitmaps[id - 1].height = height; dpyinfo->bitmaps[id - 1].width = width; @@ -558,7 +590,7 @@ image_create_bitmap_from_data (struct frame *f, char *bits, ptrdiff_t image_create_bitmap_from_file (struct frame *f, Lisp_Object file) { -#ifdef HAVE_NTGUI +#if defined (HAVE_NTGUI) || defined (HAVE_HAIKU) return -1; /* W32_TODO : bitmap support */ #else Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f); @@ -683,6 +715,10 @@ free_bitmap_record (Display_Info *dpyinfo, Bitmap_Record *bm) cairo_pattern_destroy (bm->pattern); #endif +#ifdef HAVE_HAIKU + BBitmap_free (bm->img); +#endif + if (bm->file) { xfree (bm->file); @@ -1956,6 +1992,11 @@ image_size_in_bytes (struct image *img) if (img->mask) size += w32_image_size (img->mask); +#elif defined HAVE_HAIKU + if (img->pixmap) + size += BBitmap_bytes_length (img->pixmap); + if (img->mask) + size += BBitmap_bytes_length (img->mask); #endif return size; @@ -2295,6 +2336,7 @@ compute_image_size (size_t width, size_t height, single step, but the maths for each element is much more complex and performing the steps separately makes for more readable code. */ +#ifndef HAVE_HAIKU typedef double matrix3x3[3][3]; static void @@ -2309,6 +2351,7 @@ matrix3x3_mult (matrix3x3 a, matrix3x3 b, matrix3x3 result) result[i][j] = sum; } } +#endif /* not HAVE_HAIKU */ static void compute_image_rotation (struct image *img, double *rotation) @@ -2367,6 +2410,7 @@ image_set_transform (struct frame *f, struct image *img) double rotation = 0.0; compute_image_rotation (img, &rotation); +#ifndef HAVE_HAIKU # if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS /* We want scale up operations to use a nearest neighbor filter to show real pixels instead of munging them, but scale down @@ -2537,6 +2581,34 @@ image_set_transform (struct frame *f, struct image *img) img->xform.eDx = matrix[2][0]; img->xform.eDy = matrix[2][1]; # endif +#else + if (rotation != 0 && + rotation != 90 && + rotation != 180 && + rotation != 270 && + rotation != 360) + { + image_error ("No native support for rotation by %g degrees", + make_float (rotation)); + return; + } + + rotation = fmod (rotation, 360.0); + + if (rotation == 90 || rotation == 270) + { + int w = width; + width = height; + height = w; + } + + img->have_be_transforms_p = rotation != 0 || (img->width != width) || (img->height != height); + img->be_rotate = rotation; + img->be_scale_x = 1.0 / (img->width / (double) width); + img->be_scale_y = 1.0 / (img->height / (double) height); + img->width = width; + img->height = height; +#endif /* not HAVE_HAIKU */ } #endif /* HAVE_IMAGEMAGICK || HAVE_NATIVE_TRANSFORMS */ @@ -2943,6 +3015,30 @@ image_create_x_image_and_pixmap_1 (struct frame *f, int width, int height, int d return 1; #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_HAIKU + if (depth == 0) + depth = 24; + + if (depth != 24 && depth != 1) + { + *pimg = NULL; + image_error ("Invalid image bit depth specified"); + return 0; + } + + *pixmap = BBitmap_new (width, height, depth == 1); + + if (*pixmap == NO_PIXMAP) + { + *pimg = NULL; + image_error ("Unable to create pixmap", Qnil, Qnil); + return 0; + } + + *pimg = *pixmap; + return 1; +#endif + #ifdef HAVE_NTGUI BITMAPINFOHEADER *header; @@ -3083,7 +3179,7 @@ static void gui_put_x_image (struct frame *f, Emacs_Pix_Container pimg, Emacs_Pixmap pixmap, int width, int height) { -#ifdef USE_CAIRO +#if defined USE_CAIRO || defined HAVE_HAIKU eassert (pimg == pixmap); #elif defined HAVE_X_WINDOWS GC gc; @@ -3210,7 +3306,7 @@ image_unget_x_image_or_dc (struct image *img, bool mask_p, static Emacs_Pix_Container image_get_x_image (struct frame *f, struct image *img, bool mask_p) { -#ifdef USE_CAIRO +#if defined USE_CAIRO || defined (HAVE_HAIKU) return !mask_p ? img->pixmap : img->mask; #elif defined HAVE_X_WINDOWS XImage *ximg_in_img = !mask_p ? img->ximg : img->mask_img; @@ -4166,7 +4262,7 @@ static bool xpm_load (struct frame *f, struct image *img); #endif /* not HAVE_NTGUI */ #endif /* HAVE_XPM */ -#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS +#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU /* Indices of image specification fields in xpm_format, below. */ @@ -4186,7 +4282,7 @@ enum xpm_keyword_index XPM_LAST }; -#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_PGTK +#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK /* Vector of image_keyword structures describing the format of valid XPM image specifications. */ @@ -4204,7 +4300,7 @@ static const struct image_keyword xpm_format[XPM_LAST] = {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":background", IMAGE_STRING_OR_NIL_VALUE, 0} }; -#endif /* HAVE_XPM || HAVE_NS */ +#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU || HAVE_PGTK */ #if defined HAVE_X_WINDOWS && !defined USE_CAIRO @@ -4428,7 +4524,7 @@ init_xpm_functions (void) #endif /* WINDOWSNT */ -#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_PGTK +#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK /* Value is true if COLOR_SYMBOLS is a valid color symbols list for XPM images. Such a list must consist of conses whose car and cdr are strings. */ @@ -4464,9 +4560,9 @@ xpm_image_p (Lisp_Object object) && (! fmt[XPM_COLOR_SYMBOLS].count || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))); } -#endif /* HAVE_XPM || HAVE_NS */ +#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU || HAVE_PGTK */ -#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS */ +#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS || HAVE_HAIKU */ #if defined HAVE_XPM && defined HAVE_X_WINDOWS && !defined USE_GTK ptrdiff_t @@ -4835,9 +4931,11 @@ xpm_load (struct frame *f, struct image *img) #endif /* HAVE_XPM && !USE_CAIRO */ #if (defined USE_CAIRO && defined HAVE_XPM) \ - || ((defined HAVE_NS || defined HAVE_PGTK) && !defined HAVE_XPM) + || (defined HAVE_NS && !defined HAVE_XPM) \ + || (defined HAVE_HAIKU && !defined HAVE_XPM) \ + || (defined HAVE_PGTK && !defined HAVE_XPM) -/* XPM support functions for NS where libxpm is not available, and for +/* XPM support functions for NS and Haiku where libxpm is not available, and for Cairo. Only XPM version 3 (without any extensions) is supported. */ static void xpm_put_color_table_v (Lisp_Object, const char *, @@ -5574,7 +5672,7 @@ lookup_rgb_color (struct frame *f, int r, int g, int b) { #ifdef HAVE_NTGUI return PALETTERGB (r >> 8, g >> 8, b >> 8); -#elif defined USE_CAIRO || defined HAVE_NS +#elif defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU return RGB_TO_ULONG (r >> 8, g >> 8, b >> 8); #else xsignal1 (Qfile_error, @@ -5647,7 +5745,7 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p) p = colors; for (y = 0; y < img->height; ++y) { -#if !defined USE_CAIRO && !defined HAVE_NS +#if !defined USE_CAIRO && !defined HAVE_NS && !defined HAVE_HAIKU Emacs_Color *row = p; for (x = 0; x < img->width; ++x, ++p) p->pixel = GET_PIXEL (ximg, x, y); @@ -5655,7 +5753,7 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p) { FRAME_TERMINAL (f)->query_colors (f, row, img->width); } -#else /* USE_CAIRO || HAVE_NS */ +#else /* USE_CAIRO || HAVE_NS || HAVE_HAIKU */ for (x = 0; x < img->width; ++x, ++p) { p->pixel = GET_PIXEL (ximg, x, y); @@ -5969,6 +6067,7 @@ image_disable_image (struct frame *f, struct image *img) { #ifndef HAVE_NTGUI #ifndef HAVE_NS /* TODO: NS support, however this not needed for toolbars */ +#ifndef HAVE_HAIKU #ifndef USE_CAIRO #define CrossForeground(f) BLACK_PIX_DEFAULT (f) @@ -5986,6 +6085,7 @@ image_disable_image (struct frame *f, struct image *img) if (img->mask) image_pixmap_draw_cross (f, img->mask, 0, 0, img->width, img->height, MaskForeground (f)); +#endif /* !HAVE_HAIKU */ #endif /* !HAVE_NS */ #else HDC hdc, bmpdc; @@ -6543,6 +6643,8 @@ image_can_use_native_api (Lisp_Object type) return w32_can_use_native_image_api (type); # elif defined HAVE_NS return ns_can_use_native_image_api (type); +# elif defined HAVE_HAIKU + return haiku_can_use_native_image_api (type); # else return false; # endif @@ -6616,6 +6718,9 @@ native_image_load (struct frame *f, struct image *img) # elif defined HAVE_NS return ns_load_image (f, img, image_file, image_spec_value (img->spec, QCdata, NULL)); +# elif defined HAVE_HAIKU + return haiku_load_image (f, img, image_file, + image_spec_value (img->spec, QCdata, NULL)); # else return 0; # endif @@ -9085,7 +9190,7 @@ webp_load (struct frame *f, struct image *img) } /* Create the x image and pixmap. */ - Emacs_Pix_Container ximg, mask_img; + Emacs_Pix_Container ximg, mask_img = NULL; if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, false)) goto webp_error2; @@ -9775,7 +9880,8 @@ imagemagick_load_image (struct frame *f, struct image *img, init_color_table (); -#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && ! defined (HAVE_NS) +#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && \ + ! defined (HAVE_NS) && ! defined (HAVE_HAIKU) if (imagemagick_render_type != 0) { /* Magicexportimage is normally faster than pixelpushing. This @@ -11065,7 +11171,8 @@ The list of capabilities can include one or more of the following: if (FRAME_WINDOW_P (f)) { #ifdef HAVE_NATIVE_TRANSFORMS -# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS) +# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS) \ + || defined (HAVE_HAIKU) return list2 (Qscale, Qrotate90); # elif defined (HAVE_X_WINDOWS) && defined (HAVE_XRENDER) int event_basep, error_basep; @@ -11155,7 +11262,7 @@ static struct image_type const image_types[] = { SYMBOL_INDEX (Qjpeg), jpeg_image_p, jpeg_load, image_clear_image, IMAGE_TYPE_INIT (init_jpeg_functions) }, #endif -#if defined HAVE_XPM || defined HAVE_NS || defined USE_CAIRO +#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK { SYMBOL_INDEX (Qxpm), xpm_image_p, xpm_load, image_clear_image, IMAGE_TYPE_INIT (init_xpm_functions) }, #endif @@ -11303,7 +11410,8 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (Qxbm, "xbm"); add_image_type (Qxbm); -#if defined (HAVE_XPM) || defined (HAVE_NS) || defined (USE_CAIRO) +#if defined (HAVE_XPM) || defined (HAVE_NS) \ + || defined (HAVE_HAIKU) || defined (HAVE_PGTK) DEFSYM (Qxpm, "xpm"); add_image_type (Qxpm); #endif diff --git a/src/indent.c b/src/indent.c index de6b4895616..914dabf1e72 100644 --- a/src/indent.c +++ b/src/indent.c @@ -2051,6 +2051,7 @@ window_column_x (struct window *w, Lisp_Object window, /* Restore window's buffer and point. */ +/* FIXME: Merge with `with_echo_area_buffer_unwind_data`? */ static void restore_window_buffer (Lisp_Object list) { diff --git a/src/keyboard.c b/src/keyboard.c index 79c353702c7..a4b4dce9bd5 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -3865,7 +3865,7 @@ kbd_buffer_get_event (KBOARD **kbp, /* One way or another, wait until input is available; then, if interrupt handlers have not read it, read it now. */ -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) gobble_input (); #endif if (kbd_fetch_ptr != kbd_store_ptr) @@ -5106,19 +5106,20 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, #endif ) { - /* FIXME: While track_mouse is non-nil, we do not report this + /* While 'track-mouse' is neither nil nor t, do not report this event as something that happened on the tool or tab bar since - that would break mouse dragging operations that originate from - an ordinary window beneath and expect the window to auto-scroll - as soon as the mouse cursor appears above or beneath it - (Bug#50993). Since this "fix" might break track_mouse based - operations originating from the tool or tab bar itself, such - operations should set track_mouse to some special value that - would be recognized by the following check. + that would break mouse drag operations that originate from an + ordinary window beneath that bar and expect the window to + auto-scroll as soon as the mouse cursor appears above or + beneath it (Bug#50993). We do allow reports for t, because + applications may have set 'track-mouse' to t and still expect a + click on the tool or tab bar to get through (Bug#51794). - This issue should be properly handled by 'mouse-drag-track' and - friends, so the below is only a temporary workaround. */ - if (NILP (track_mouse)) + FIXME: This is a preliminary fix for the bugs cited above and + awaits a solution that includes a convention for all special + values of 'track-mouse' and their documentation in the Elisp + manual. */ + if (NILP (track_mouse) || EQ (track_mouse, Qt)) posn = EQ (window_or_frame, f->tab_bar_window) ? Qtab_bar : Qtool_bar; /* Kludge alert: for mouse events on the tab bar and tool bar, keyboard.c wants the frame, not the special-purpose window @@ -5983,7 +5984,11 @@ make_lispy_event (struct input_event *event) ASIZE (wheel_syms)); } - if (NUMBERP (event->arg)) + 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))))); + else if (NUMBERP (event->arg)) return list4 (head, position, make_fixnum (double_click_count), event->arg); else if (event->modifiers & (double_modifier | triple_modifier)) @@ -6139,7 +6144,7 @@ make_lispy_event (struct input_event *event) return Fcons (Qxwidget_event, event->arg); case XWIDGET_DISPLAY_EVENT: - return list2 (Qxwidget_display_event, event->arg); + return Fcons (Qxwidget_display_event, event->arg); #endif #ifdef USE_FILE_NOTIFY @@ -7188,7 +7193,7 @@ tty_read_avail_input (struct terminal *terminal, static void handle_async_input (void) { -#ifdef USABLE_SIGIO +#ifndef DOS_NT while (1) { int nread = gobble_input (); @@ -7251,7 +7256,7 @@ totally_unblock_input (void) unblock_input_to (0); } -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) void handle_input_available_signal (int sig) @@ -7267,7 +7272,7 @@ deliver_input_available_signal (int sig) { deliver_process_signal (sig, handle_input_available_signal); } -#endif /* USABLE_SIGIO */ +#endif /* defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) */ /* User signal events. */ @@ -7337,7 +7342,7 @@ handle_user_signal (int sig) } p->npending++; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) if (interrupt_input) handle_input_available_signal (sig); else @@ -11107,7 +11112,7 @@ See also `current-input-mode'. */) (Lisp_Object interrupt) { bool new_interrupt_input; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) #ifdef HAVE_X_WINDOWS if (x_display_list != NULL) { @@ -11118,9 +11123,9 @@ See also `current-input-mode'. */) else #endif /* HAVE_X_WINDOWS */ new_interrupt_input = !NILP (interrupt); -#else /* not USABLE_SIGIO */ +#else /* not USABLE_SIGIO || USABLE_SIGPOLL */ new_interrupt_input = false; -#endif /* not USABLE_SIGIO */ +#endif /* not USABLE_SIGIO || USABLE_SIGPOLL */ if (new_interrupt_input != interrupt_input) { @@ -11549,12 +11554,16 @@ init_keyboard (void) sigaction (SIGQUIT, &action, 0); #endif /* not DOS_NT */ } -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) if (!noninteractive) { struct sigaction action; emacs_sigaction_init (&action, deliver_input_available_signal); +#ifdef USABLE_SIGIO sigaction (SIGIO, &action, 0); +#else + sigaction (SIGPOLL, &action, 0); +#endif } #endif diff --git a/src/keymap.c b/src/keymap.c index 29d2ca7ab7e..0b882958b94 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -73,7 +73,8 @@ static Lisp_Object where_is_cache; /* Which keymaps are reverse-stored in the cache. */ static Lisp_Object where_is_cache_keymaps; -static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object); +static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object, + bool); static Lisp_Object define_as_prefix (Lisp_Object, Lisp_Object); static void describe_vector (Lisp_Object, Lisp_Object, Lisp_Object, @@ -130,7 +131,8 @@ in case you use it as a menu with `x-popup-menu'. */) void initial_define_lispy_key (Lisp_Object keymap, const char *keyname, const char *defname) { - store_in_keymap (keymap, intern_c_string (keyname), intern_c_string (defname)); + store_in_keymap (keymap, intern_c_string (keyname), + intern_c_string (defname), false); } DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0, @@ -729,7 +731,8 @@ get_keyelt (Lisp_Object object, bool autoload) } static Lisp_Object -store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) +store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, + Lisp_Object def, bool remove) { /* Flush any reverse-map cache. */ where_is_cache = Qnil; @@ -805,21 +808,26 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) } else if (CHAR_TABLE_P (elt)) { + Lisp_Object sdef = def; + if (remove) + sdef = Qnil; + /* nil has a special meaning for char-tables, so + we use something else to record an explicitly + unbound entry. */ + else if (NILP (sdef)) + sdef = Qt; + /* Character codes with modifiers are not included in a char-table. All character codes without modifiers are included. */ if (FIXNATP (idx) && !(XFIXNAT (idx) & CHAR_MODIFIER_MASK)) { - Faset (elt, idx, - /* nil has a special meaning for char-tables, so - we use something else to record an explicitly - unbound entry. */ - NILP (def) ? Qt : def); + Faset (elt, idx, sdef); return def; } else if (CONSP (idx) && CHARACTERP (XCAR (idx))) { - Fset_char_table_range (elt, idx, NILP (def) ? Qt : def); + Fset_char_table_range (elt, idx, sdef); return def; } insertion_point = tail; @@ -838,7 +846,12 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) else if (EQ (idx, XCAR (elt))) { CHECK_IMPURE (elt, XCONS (elt)); - XSETCDR (elt, def); + if (remove) + /* Remove the element. */ + insertion_point = Fdelq (elt, insertion_point); + else + /* Just set the definition. */ + XSETCDR (elt, def); return def; } else if (CONSP (idx) @@ -851,7 +864,10 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) if (from <= XFIXNAT (XCAR (elt)) && to >= XFIXNAT (XCAR (elt))) { - XSETCDR (elt, def); + if (remove) + insertion_point = Fdelq (elt, insertion_point); + else + XSETCDR (elt, def); if (from == to) return def; } @@ -1037,16 +1053,16 @@ possibly_translate_key_sequence (Lisp_Object key, ptrdiff_t *length) { /* KEY is on the ["C-c"] format, so translate to internal format. */ - if (NILP (Ffboundp (Qkbd_valid_p))) + if (NILP (Ffboundp (Qkey_valid_p))) xsignal2 (Qerror, - build_string ("`kbd-valid-p' is not defined, so this syntax can't be used: %s"), + build_string ("`key-valid-p' is not defined, so this syntax can't be used: %s"), key); - if (NILP (call1 (Qkbd_valid_p, AREF (key, 0)))) - xsignal2 (Qerror, build_string ("Invalid `kbd' syntax: %S"), key); - key = call1 (Qkbd, AREF (key, 0)); + if (NILP (call1 (Qkey_valid_p, AREF (key, 0)))) + xsignal2 (Qerror, build_string ("Invalid `key-parse' syntax: %S"), key); + key = call1 (Qkey_parse, AREF (key, 0)); *length = CHECK_VECTOR_OR_STRING (key); if (*length == 0) - xsignal2 (Qerror, build_string ("Invalid `kbd' syntax: %S"), key); + xsignal2 (Qerror, build_string ("Invalid `key-parse' syntax: %S"), key); } return key; @@ -1054,8 +1070,11 @@ possibly_translate_key_sequence (Lisp_Object key, ptrdiff_t *length) /* GC is possible in this function if it autoloads a keymap. */ -DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 3, 0, +DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 4, 0, doc: /* In KEYMAP, define key sequence KEY as DEF. +This is a legacy function; see `keymap-set' for the recommended +function to use instead. + KEYMAP is a keymap. KEY is a string or a vector of symbols and characters, representing a @@ -1082,10 +1101,16 @@ DEF is anything that can be a key's definition: or an extended menu item definition. (See info node `(elisp)Extended Menu Items'.) +If REMOVE is non-nil, the definition will be removed. This is almost +the same as setting the definition to nil, but makes a difference if +the KEYMAP has a parent, and KEY is shadowing the same binding in the +parent. With REMOVE, subsequent lookups will return the binding in +the parent, and with a nil DEF, the lookups will return nil. + If KEYMAP is a sparse keymap with a binding for KEY, the existing binding is altered. If there is no binding for KEY, the new pair binding KEY to DEF is added at the front of KEYMAP. */) - (Lisp_Object keymap, Lisp_Object key, Lisp_Object def) + (Lisp_Object keymap, Lisp_Object key, Lisp_Object def, Lisp_Object remove) { bool metized = false; @@ -1155,7 +1180,7 @@ binding KEY to DEF is added at the front of KEYMAP. */) message_with_string ("Key sequence contains invalid event %s", c, 1); if (idx == length) - return store_in_keymap (keymap, c, def); + return store_in_keymap (keymap, c, def, !NILP (remove)); Lisp_Object cmd = access_keymap (keymap, c, 0, 1, 1); @@ -1260,6 +1285,9 @@ lookup_key_1 (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default) DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0, doc: /* Look up key sequence KEY in KEYMAP. Return the definition. +This is a legacy function; see `keymap-lookup' for the recommended +function to use instead. + A value of nil means undefined. See doc of `define-key' for kinds of definitions. @@ -1413,7 +1441,7 @@ static Lisp_Object define_as_prefix (Lisp_Object keymap, Lisp_Object c) { Lisp_Object cmd = Fmake_sparse_keymap (Qnil); - store_in_keymap (keymap, c, cmd); + store_in_keymap (keymap, c, cmd, false); return cmd; } @@ -3430,6 +3458,6 @@ that describe key bindings. That is why the default is nil. */); defsubr (&Swhere_is_internal); defsubr (&Sdescribe_buffer_bindings); - DEFSYM (Qkbd, "kbd"); - DEFSYM (Qkbd_valid_p, "kbd-valid-p"); + DEFSYM (Qkey_parse, "key-parse"); + DEFSYM (Qkey_valid_p, "key-valid-p"); } diff --git a/src/lisp.h b/src/lisp.h index 31656bb3b1c..19caba40014 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -138,7 +138,12 @@ verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); buffers and strings. Emacs never allocates objects larger than PTRDIFF_MAX bytes, as they cause problems with pointer subtraction. In C99, pD can always be "t"; configure it here for the sake of - pre-C99 libraries such as glibc 2.0 and Solaris 8. */ + pre-C99 libraries such as glibc 2.0 and Solaris 8. + + On Haiku, the size of ptrdiff_t is inconsistent with the value of + PTRDIFF_MAX. In that case, "t" should be sufficient. */ + +#ifndef HAIKU #if PTRDIFF_MAX == INT_MAX # define pD "" #elif PTRDIFF_MAX == LONG_MAX @@ -148,6 +153,9 @@ verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); #else # define pD "t" #endif +#else +# define pD "t" +#endif /* Convenience macro for rarely-used functions that do not return. */ #define AVOID _Noreturn ATTRIBUTE_COLD void @@ -3330,7 +3338,7 @@ struct frame; /* Define if the windowing system provides a menu bar. */ #if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ - || defined (HAVE_NS) || defined (USE_GTK) + || defined (HAVE_NS) || defined (USE_GTK) || defined (HAVE_HAIKU) #define HAVE_EXT_MENU_BAR true #endif @@ -4429,7 +4437,7 @@ extern Lisp_Object menu_bar_items (Lisp_Object); extern Lisp_Object tab_bar_items (Lisp_Object, int *); extern Lisp_Object tool_bar_items (Lisp_Object, int *); extern void discard_mouse_events (void); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) void handle_input_available_signal (int); #endif extern Lisp_Object pending_funcalls; diff --git a/src/lread.c b/src/lread.c index 3052bcbd063..2e63ec48912 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2709,7 +2709,7 @@ read_escape (Lisp_Object readcharfun, bool stringp) c = read_escape (readcharfun, 0); if ((c & ~CHAR_MODIFIER_MASK) == '?') return 0177 | (c & CHAR_MODIFIER_MASK); - else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK))) + else if (! ASCII_CHAR_P ((c & ~CHAR_MODIFIER_MASK))) return c | ctrl_modifier; /* ASCII control chars are made from letters (both cases), as well as the non-letters within 0100...0137. */ diff --git a/src/macfont.m b/src/macfont.m index 1426cae6dc4..ce7a5ec8cda 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -2928,7 +2928,7 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no { if (s->hl == DRAW_CURSOR) { - CGColorRef *colorref = get_cgcolor_from_nscolor (FRAME_CURSOR_COLOR (f), f); + CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_CURSOR_COLOR (f), f); CGContextSetFillColorWithColor (context, colorref); CGColorRelease (colorref); } @@ -2944,7 +2944,7 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no CGContextScaleCTM (context, 1, -1); if (s->hl == DRAW_CURSOR) { - CGColorRef *colorref = get_cgcolor_from_nscolor (FRAME_BACKGROUND_COLOR (f), f); + CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_BACKGROUND_COLOR (f), f); CGContextSetFillColorWithColor (context, colorref); CGColorRelease (colorref); } diff --git a/src/menu.c b/src/menu.c index 780b71eba6b..b9da85ef3d5 100644 --- a/src/menu.c +++ b/src/menu.c @@ -50,7 +50,8 @@ extern AppendMenuW_Proc unicode_append_menu; static bool have_boxes (void) { -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined(HAVE_NS) +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined (HAVE_NS) \ + || defined (HAVE_HAIKU) if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame))) return 1; #endif @@ -422,7 +423,8 @@ single_menu_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy, void *sk AREF (item_properties, ITEM_PROPERTY_SELECTED), AREF (item_properties, ITEM_PROPERTY_HELP)); -#ifdef HAVE_EXT_MENU_BAR +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \ + || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) || defined (HAVE_PGTK) /* Display a submenu using the toolkit. */ if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame)) && ! (NILP (map) || NILP (enabled))) @@ -872,6 +874,10 @@ update_submenu_strings (widget_value *first_wv) } } +#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI */ +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \ + || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) + /* Find the menu selection and store it in the keyboard buffer. F is the frame the menu is on. MENU_BAR_ITEMS_USED is the length of VECTOR. @@ -959,7 +965,7 @@ find_and_call_menu_selection (struct frame *f, int menu_bar_items_used, SAFE_FREE (); } -#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI */ +#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI || HAVE_HAIKU */ #ifdef HAVE_NS /* As above, but return the menu selection instead of storing in kb buffer. @@ -1107,7 +1113,7 @@ into menu items. */) Lisp_Object x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) { - Lisp_Object keymap, tem, tem2; + Lisp_Object keymap, tem, tem2 = Qnil; int xpos = 0, ypos = 0; Lisp_Object title; const char *error_name = NULL; @@ -1246,8 +1252,21 @@ x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) CHECK_LIVE_WINDOW (window); f = XFRAME (WINDOW_FRAME (win)); - xpos = WINDOW_LEFT_EDGE_X (win); - ypos = WINDOW_TOP_EDGE_Y (win); + if (FIXNUMP (tem2)) + { + /* Clicks in the text area, where TEM2 is a buffer + position, are relative to the top-left edge of the text + area, see keyboard.c:make_lispy_position. */ + xpos = window_box_left (win, TEXT_AREA); + ypos = (WINDOW_TOP_EDGE_Y (win) + + WINDOW_TAB_LINE_HEIGHT (win) + + WINDOW_HEADER_LINE_HEIGHT (win)); + } + else + { + xpos = WINDOW_LEFT_EDGE_X (win); + ypos = WINDOW_TOP_EDGE_Y (win); + } } else /* ??? Not really clean; should be CHECK_WINDOW_OR_FRAME, diff --git a/src/nsfns.m b/src/nsfns.m index f4d81722460..c2791aa15a9 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -1365,6 +1365,10 @@ Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side. NILP (Vmenu_bar_mode) ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qtab_bar_lines, + NILP (Vtab_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qtool_bar_lines, NILP (Vtool_bar_mode) ? make_fixnum (0) : make_fixnum (1), diff --git a/src/nsselect.m b/src/nsselect.m index 5ab3ef77fec..8b23f6f51ad 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -215,9 +215,78 @@ Updated by Christian Limpach (chris@nice.ch) static Lisp_Object ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target) { + NSDictionary *typeLookup; id pb; pb = ns_symbol_to_pb (symbol); - return pb != nil ? ns_string_from_pasteboard (pb) : Qnil; + + /* Dictionary for looking up NS types from MIME types, and vice versa. */ + typeLookup + = [NSDictionary + dictionaryWithObjectsAndKeys: + @"text/plain", NSPasteboardTypeURL, +#if NS_USE_NSPasteboardTypeFileURL + @"text/plain", NSPasteboardTypeFileURL, +#else + @"text/plain", NSFilenamesPboardType, +#endif +#ifdef NS_IMPL_COCOA + /* FIXME: I believe these are actually available in recent + versions of GNUstep. */ + @"text/plain", NSPasteboardTypeMultipleTextSelection, + @"image/png", NSPasteboardTypePNG, +#endif + @"text/html", NSPasteboardTypeHTML, + @"application/pdf", NSPasteboardTypePDF, + @"application/rtf", NSPasteboardTypeRTF, + @"application/rtfd", NSPasteboardTypeRTFD, + @"STRING", NSPasteboardTypeString, + @"text/plain", NSPasteboardTypeTabularText, + @"image/tiff", NSPasteboardTypeTIFF, + nil]; + + if (EQ (target, QTARGETS)) + { + NSMutableArray *types = [NSMutableArray arrayWithCapacity:3]; + + NSString *type; + NSEnumerator *e = [[pb types] objectEnumerator]; + while (type = [e nextObject]) + { + NSString *val = [typeLookup valueForKey:type]; + if (val && ! [types containsObject:val]) + [types addObject:val]; + } + + Lisp_Object v = Fmake_vector (make_fixnum ([types count]+1), Qnil); + ASET (v, 0, QTARGETS); + + for (int i = 0 ; i < [types count] ; i++) + ASET (v, i+1, intern ([[types objectAtIndex:i] UTF8String])); + + return v; + } + else + { + NSData *d; + NSArray *availableTypes; + NSString *result, *t; + + if (!NILP (target)) + availableTypes + = [typeLookup allKeysForObject: + [NSString stringWithLispString:SYMBOL_NAME (target)]]; + else + availableTypes = [NSArray arrayWithObject:NSPasteboardTypeString]; + + t = [pb availableTypeFromArray:availableTypes]; + + result = [pb stringForType:t]; + if (result) + return [result lispString]; + + d = [pb dataForType:t]; + return make_string ([d bytes], [d length]); + } } @@ -234,8 +303,6 @@ Updated by Christian Limpach (chris@nice.ch) ns_string_from_pasteboard (id pb) { NSString *type, *str; - const char *utfStr; - int length; type = [pb availableTypeFromArray: ns_return_types]; if (type == nil) @@ -260,6 +327,14 @@ Updated by Christian Limpach (chris@nice.ch) } } + /* FIXME: Is the below EOL conversion even needed? I've removed it + for now so we can see if it causes problems. */ + return [str lispString]; + +#if 0 + const char *utfStr; + int length; + /* assume UTF8 */ NS_DURING { @@ -294,6 +369,7 @@ Updated by Christian Limpach (chris@nice.ch) NS_ENDHANDLER return make_string (utfStr, length); +#endif } @@ -491,6 +567,8 @@ Updated by Christian Limpach (chris@nice.ch) DEFSYM (QTEXT, "TEXT"); DEFSYM (QFILE_NAME, "FILE_NAME"); + DEFSYM (QTARGETS, "TARGETS"); + defsubr (&Sns_disown_selection_internal); defsubr (&Sns_get_selection); defsubr (&Sns_own_selection_internal); diff --git a/src/nsterm.h b/src/nsterm.h index 8175f996644..a32b8fe149c 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -1346,9 +1346,18 @@ enum NSWindowTabbingMode #if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_14) /* Deprecated in macOS 10.14. */ +/* FIXME: Some of these new names, if not all, are actually available + in some recent version of GNUstep. */ #define NSPasteboardTypeString NSStringPboardType #define NSPasteboardTypeTabularText NSTabularTextPboardType #define NSPasteboardTypeURL NSURLPboardType +#define NSPasteboardTypeHTML NSHTMLPboardType +#define NSPasteboardTypeMultipleTextSelection NSMultipleTextSelectionPboardType +#define NSPasteboardTypePDF NSPDFPboardType +#define NSPasteboardTypePNG NSPNGPboardType +#define NSPasteboardTypeRTF NSRTFPboardType +#define NSPasteboardTypeRTFD NSRTFDPboardType +#define NSPasteboardTypeTIFF NSTIFFPboardType #define NSControlStateValueOn NSOnState #define NSControlStateValueOff NSOffState #define NSBezelStyleRounded NSRoundedBezelStyle diff --git a/src/nsterm.m b/src/nsterm.m index 1f17a30272c..747539eae64 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -535,8 +535,11 @@ - (NSColor *)colorUsingDefaultColorSpace NSTRACE ("ns_init_locale"); - @try + /* If we were run from a terminal then assume an unset LANG variable + is intentional and don't try to "fix" it. */ + if (!isatty (STDIN_FILENO)) { + char *oldLocale = setlocale (LC_ALL, NULL); /* It seems macOS should probably use UTF-8 everywhere. 'localeIdentifier' does not specify the encoding, and I can't find any way to get the OS to tell us which encoding to use, @@ -544,12 +547,12 @@ - (NSColor *)colorUsingDefaultColorSpace NSString *localeID = [NSString stringWithFormat:@"%@.UTF-8", [locale localeIdentifier]]; - /* Set LANG to locale, but not if LANG is already set. */ - setenv("LANG", [localeID UTF8String], 0); - } - @catch (NSException *e) - { - NSLog (@"Locale detection failed: %@: %@", [e name], [e reason]); + /* Check the locale ID is valid and if so set LANG, but not if + it is already set. */ + if (setlocale (LC_ALL, [localeID UTF8String])) + setenv("LANG", [localeID UTF8String], 0); + + setlocale (LC_ALL, oldLocale); } } @@ -6557,6 +6560,7 @@ - (void)mouseDown: (NSEvent *)theEvent */ bool horizontal; int lines = 0; + int x = 0, y = 0; int scrollUp = NO; /* FIXME: At the top or bottom of the buffer we should @@ -6592,23 +6596,33 @@ - (void)mouseDown: (NSEvent *)theEvent * reset the total delta for the direction we're NOT * scrolling so that small movements don't add up. */ if (abs (totalDeltaX) > abs (totalDeltaY) - && abs (totalDeltaX) > lineHeight) + && (!x_coalesce_scroll_events + || abs (totalDeltaX) > lineHeight)) { horizontal = YES; scrollUp = totalDeltaX > 0; lines = abs (totalDeltaX / lineHeight); - totalDeltaX = totalDeltaX % lineHeight; + x = totalDeltaX; + if (!x_coalesce_scroll_events) + totalDeltaX = 0; + else + totalDeltaX = totalDeltaX % lineHeight; totalDeltaY = 0; } else if (abs (totalDeltaY) >= abs (totalDeltaX) - && abs (totalDeltaY) > lineHeight) + && (!x_coalesce_scroll_events + || abs (totalDeltaY) > lineHeight)) { horizontal = NO; scrollUp = totalDeltaY > 0; lines = abs (totalDeltaY / lineHeight); - totalDeltaY = totalDeltaY % lineHeight; + y = totalDeltaY; + if (!x_coalesce_scroll_events) + totalDeltaY = 0; + else + totalDeltaY = totalDeltaY % lineHeight; totalDeltaX = 0; } @@ -6634,13 +6648,17 @@ - (void)mouseDown: (NSEvent *)theEvent ? ceil (fabs (delta)) : 1; scrollUp = delta > 0; + x = [theEvent scrollingDeltaX]; + y = [theEvent scrollingDeltaY]; } - if (lines == 0) + if (lines == 0 && x_coalesce_scroll_events) return; emacs_event->kind = horizontal ? HORIZ_WHEEL_EVENT : WHEEL_EVENT; - emacs_event->arg = (make_fixnum (lines)); + emacs_event->arg = list3 (make_fixnum (lines), + make_float (x), + make_float (y)); emacs_event->code = 0; emacs_event->modifiers = EV_MODIFIERS (theEvent) | @@ -10002,6 +10020,11 @@ Nil means use fullscreen the old (< 10.7) way. The old way works better with x_underline_at_descent_line, doc: /* SKIP: real doc in xterm.c. */); x_underline_at_descent_line = 0; + + DEFVAR_BOOL ("x-coalesce-scroll-events", x_coalesce_scroll_events, + doc: /* SKIP: real doc in xterm.c. */); + x_coalesce_scroll_events = true; + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); /* Tell Emacs about this window system. */ diff --git a/src/process.c b/src/process.c index 42743f6531a..eb27ddef45f 100644 --- a/src/process.c +++ b/src/process.c @@ -259,7 +259,7 @@ static bool process_output_skip; static void start_process_unwind (Lisp_Object); static void create_process (Lisp_Object, char **, Lisp_Object); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) static bool keyboard_bit_set (fd_set *); #endif static void deactivate_process (Lisp_Object); @@ -5592,6 +5592,13 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, nfds = pgtk_select (max_desc + 1, &Available, (check_write ? &Writeok : 0), NULL, &timeout, NULL); +#elif !defined USABLE_SIGIO && !defined WINDOWSNT + /* If we're polling for input, don't get stuck in select for + more than 25 msec. */ + struct timespec short_timeout = make_timespec (0, 25000000); + if ((read_kbd || !NILP (wait_for_cell)) + && timespec_cmp (short_timeout, timeout) < 0) + timeout = short_timeout; #elif defined HAVE_GLIB && !defined HAVE_NS /* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ nfds = xg_select (max_desc + 1, @@ -5725,7 +5732,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) /* If we think we have keyboard input waiting, but didn't get SIGIO, go read it. This can happen with X on BSD after logging out. In that case, there really is no input and no SIGIO, @@ -5733,7 +5740,11 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (read_kbd && interrupt_input && keyboard_bit_set (&Available) && ! noninteractive) +#ifdef USABLE_SIGIO handle_input_available_signal (SIGIO); +#else + handle_input_available_signal (SIGPOLL); +#endif #endif /* If checking input just got us a size-change event from X, @@ -7727,7 +7738,7 @@ delete_gpm_wait_descriptor (int desc) # endif -# ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) /* Return true if *MASK has a bit set that corresponds to one of the keyboard input descriptors. */ diff --git a/src/sound.c b/src/sound.c index 9041076bdc0..d42bc8550d3 100644 --- a/src/sound.c +++ b/src/sound.c @@ -299,11 +299,15 @@ sound_perror (const char *msg) int saved_errno = errno; turn_on_atimers (1); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) { sigset_t unblocked; sigemptyset (&unblocked); +#ifdef USABLE_SIGIO sigaddset (&unblocked, SIGIO); +#else + sigaddset (&unblocked, SIGPOLL); +#endif pthread_sigmask (SIG_UNBLOCK, &unblocked, 0); } #endif @@ -698,7 +702,7 @@ static void vox_configure (struct sound_device *sd) { int val; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t oldset, blocked; #endif @@ -708,9 +712,13 @@ vox_configure (struct sound_device *sd) interrupted by a signal. Block the ones we know to cause troubles. */ turn_on_atimers (0); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigemptyset (&blocked); +#ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +#else + sigaddset (&blocked, SIGPOLL); +#endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); #endif @@ -744,7 +752,7 @@ vox_configure (struct sound_device *sd) } turn_on_atimers (1); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) pthread_sigmask (SIG_SETMASK, &oldset, 0); #endif } @@ -760,10 +768,14 @@ vox_close (struct sound_device *sd) /* On GNU/Linux, it seems that the device driver doesn't like to be interrupted by a signal. Block the ones we know to cause troubles. */ -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t blocked, oldset; sigemptyset (&blocked); +#ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +#else + sigaddset (&blocked, SIGPOLL); +#endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); #endif turn_on_atimers (0); @@ -772,7 +784,7 @@ vox_close (struct sound_device *sd) ioctl (sd->fd, SNDCTL_DSP_SYNC, NULL); turn_on_atimers (1); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) pthread_sigmask (SIG_SETMASK, &oldset, 0); #endif diff --git a/src/sysdep.c b/src/sysdep.c index 8eaee224987..5e13dd097ec 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -678,6 +678,9 @@ sys_subshell (void) #ifdef USABLE_SIGIO saved_handlers[3].code = SIGIO; saved_handlers[4].code = 0; +#elif defined (USABLE_SIGPOLL) + saved_handlers[3].code = SIGPOLL; + saved_handlers[4].code = 0; #else saved_handlers[3].code = 0; #endif @@ -788,6 +791,7 @@ init_sigio (int fd) } #ifndef DOS_NT +#ifdef F_SETOWN static void reset_sigio (int fd) { @@ -795,12 +799,13 @@ reset_sigio (int fd) fcntl (fd, F_SETFL, old_fcntl_flags[fd]); #endif } +#endif /* F_SETOWN */ #endif void request_sigio (void) { -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t unblocked; if (noninteractive) @@ -810,7 +815,11 @@ request_sigio (void) # ifdef SIGWINCH sigaddset (&unblocked, SIGWINCH); # endif +# ifdef USABLE_SIGIO sigaddset (&unblocked, SIGIO); +# else + sigaddset (&unblocked, SIGPOLL); +# endif pthread_sigmask (SIG_UNBLOCK, &unblocked, 0); interrupts_deferred = 0; @@ -820,7 +829,7 @@ request_sigio (void) void unrequest_sigio (void) { -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t blocked; if (noninteractive) @@ -830,7 +839,11 @@ unrequest_sigio (void) # ifdef SIGWINCH sigaddset (&blocked, SIGWINCH); # endif +# ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +# else + sigaddset (&blocked, SIGPOLL); +# endif pthread_sigmask (SIG_BLOCK, &blocked, 0); interrupts_deferred = 1; #endif @@ -1256,9 +1269,12 @@ init_sys_modes (struct tty_display_info *tty_out) /* This code added to insure that, if flow-control is not to be used, we have an unlocked terminal at the start. */ +#ifndef HAIKU /* On Haiku, TCXONC is a no-op and causes spurious + compiler warnings. */ #ifdef TCXONC if (!tty_out->flow_control) ioctl (fileno (tty_out->input), TCXONC, 1); #endif +#endif /* HAIKU */ #ifdef TIOCSTART if (!tty_out->flow_control) ioctl (fileno (tty_out->input), TIOCSTART, 0); #endif @@ -1674,6 +1690,8 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler) sigaddset (&action->sa_mask, SIGQUIT); #ifdef USABLE_SIGIO sigaddset (&action->sa_mask, SIGIO); +#elif defined (USABLE_SIGPOLL) + sigaddset (&action->sa_mask, SIGPOLL); #endif } @@ -2772,6 +2790,7 @@ static const struct speed_struct speeds[] = #ifdef B150 { 150, B150 }, #endif +#ifndef HAVE_TINY_SPEED_T #ifdef B200 { 200, B200 }, #endif @@ -2859,6 +2878,7 @@ static const struct speed_struct speeds[] = #ifdef B4000000 { 4000000, B4000000 }, #endif +#endif /* HAVE_TINY_SPEED_T */ }; /* Convert a numerical speed (e.g., 9600) to a Bnnn constant (e.g., @@ -3120,8 +3140,9 @@ list_system_processes (void) } /* The WINDOWSNT implementation is in w32.c. - The MSDOS implementation is in dosfns.c. */ -#elif !defined (WINDOWSNT) && !defined (MSDOS) + The MSDOS implementation is in dosfns.c. + The Haiku implementation is in haiku.c. */ +#elif !defined (WINDOWSNT) && !defined (MSDOS) && !defined (HAIKU) Lisp_Object list_system_processes (void) @@ -4200,8 +4221,9 @@ system_process_attributes (Lisp_Object pid) } /* The WINDOWSNT implementation is in w32.c. - The MSDOS implementation is in dosfns.c. */ -#elif !defined (WINDOWSNT) && !defined (MSDOS) + The MSDOS implementation is in dosfns.c. + The HAIKU implementation is in haiku.c. */ +#elif !defined (WINDOWSNT) && !defined (MSDOS) && !defined (HAIKU) Lisp_Object system_process_attributes (Lisp_Object pid) diff --git a/src/term.c b/src/term.c index b4f3dfc25e4..8e106e7c639 100644 --- a/src/term.c +++ b/src/term.c @@ -1358,7 +1358,7 @@ term_get_fkeys_1 (void) char *sequence = tgetstr (keys[i].cap, address); if (sequence) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), - make_vector (1, intern (keys[i].name))); + make_vector (1, intern (keys[i].name)), Qnil); } /* The uses of the "k0" capability are inconsistent; sometimes it @@ -1377,13 +1377,13 @@ 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"))); + make_vector (1, intern ("f0")), Qnil); Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi), - make_vector (1, intern ("f10"))); + make_vector (1, intern ("f10")), Qnil); } else if (k0) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), - make_vector (1, intern (k0_name))); + make_vector (1, intern (k0_name)), Qnil); } /* Set up cookies for numbered function keys above f10. */ @@ -1405,8 +1405,10 @@ term_get_fkeys_1 (void) if (sequence) { sprintf (fkey, "f%d", i); - Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), - make_vector (1, intern (fkey))); + Fdefine_key (KVAR (kboard, Vinput_decode_map), + build_string (sequence), + make_vector (1, intern (fkey)), + Qnil); } } } @@ -1422,7 +1424,7 @@ term_get_fkeys_1 (void) char *sequence = tgetstr (cap2, address); \ if (sequence) \ Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), \ - make_vector (1, intern (sym))); \ + make_vector (1, intern (sym)), Qnil); \ } /* if there's no key_next keycap, map key_npage to `next' keysym */ diff --git a/src/termhooks.h b/src/termhooks.h index 7e8318c07af..f0c3ffd57b1 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -62,6 +62,7 @@ enum output_method output_w32, output_ns, output_pgtk + output_haiku }; /* Input queue declarations and hooks. */ @@ -120,7 +121,10 @@ enum event_kind .timestamp gives a timestamp (in milliseconds) for the event. .arg may contain the number of - lines to scroll. */ + lines to scroll, or a list of + the form (NUMBER-OF-LINES . (X Y)) where + X and Y are the number of pixels + on each axis to scroll by. */ HORIZ_WHEEL_EVENT, /* A wheel event generated by a second horizontal wheel that is present on some mice. See WHEEL_EVENT. */ @@ -450,6 +454,7 @@ struct terminal struct w32_display_info *w32; /* w32term.h */ struct ns_display_info *ns; /* nsterm.h */ struct pgtk_display_info *pgtk; /* pgtkterm.h */ + struct haiku_display_info *haiku; /* haikuterm.h */ } display_info; @@ -841,6 +846,9 @@ extern struct terminal *terminal_list; #elif defined (HAVE_PGTK) #define TERMINAL_FONT_CACHE(t) \ (t->type == output_pgtk ? t->display_info.pgtk->name_list_element : Qnil) +#elif defined (HAVE_HAIKU) +#define TERMINAL_FONT_CACHE(t) \ + (t->type == output_haiku ? t->display_info.haiku->name_list_element : Qnil) #endif extern struct terminal *decode_live_terminal (Lisp_Object); diff --git a/src/terminal.c b/src/terminal.c index dd2a8aa7188..a9ecb63d85d 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -447,6 +447,8 @@ possible return values. */) return Qns; case output_pgtk: return Qpgtk; + case output_haiku: + return Qhaiku; default: emacs_abort (); } diff --git a/src/verbose.mk.in b/src/verbose.mk.in index a5ff931ed09..9252971acc3 100644 --- a/src/verbose.mk.in +++ b/src/verbose.mk.in @@ -23,7 +23,9 @@ ifeq (${V},1) AM_V_AR = AM_V_at = AM_V_CC = +AM_V_CXX = AM_V_CCLD = +AM_V_CXXLD = AM_V_ELC = AM_V_ELN = AM_V_GEN = @@ -34,7 +36,9 @@ else AM_V_AR = @echo " AR " $@; AM_V_at = @ AM_V_CC = @echo " CC " $@; +AM_V_CXX = @echo " CXX " $@; AM_V_CCLD = @echo " CCLD " $@; +AM_V_CXXLD = @echo " CXXLD " $@; ifeq ($(HAVE_NATIVE_COMP),yes) ifeq ($(NATIVE_DISABLED),1) AM_V_ELC = @echo " ELC " $@; diff --git a/src/w32font.c b/src/w32font.c index 752acdc9048..2d09f459f89 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -2022,13 +2022,9 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec) tmp = AREF (font_spec, FONT_DPI_INDEX); if (FIXNUMP (tmp)) - { - dpi = XFIXNUM (tmp); - } + dpi = XFIXNUM (tmp); else if (FLOATP (tmp)) - { - dpi = (int) (XFLOAT_DATA (tmp) + 0.5); - } + dpi = (int) (XFLOAT_DATA (tmp) + 0.5); /* Height */ tmp = AREF (font_spec, FONT_SIZE_INDEX); diff --git a/src/w32inevt.c b/src/w32inevt.c index 9a69b32bcb0..4cc01d31c94 100644 --- a/src/w32inevt.c +++ b/src/w32inevt.c @@ -420,7 +420,7 @@ w32_console_mouse_position (struct frame **f, *f = get_frame (); *bar_window = Qnil; *part = scroll_bar_above_handle; - SELECTED_FRAME ()->mouse_moved = 0; + (*f)->mouse_moved = 0; XSETINT (*x, movement_pos.X); XSETINT (*y, movement_pos.Y); @@ -436,7 +436,8 @@ mouse_moved_to (int x, int y) /* If we're in the same place, ignore it. */ if (x != movement_pos.X || y != movement_pos.Y) { - SELECTED_FRAME ()->mouse_moved = 1; + struct frame *f = get_frame (); + f->mouse_moved = 1; movement_pos.X = x; movement_pos.Y = y; movement_time = GetTickCount (); @@ -470,11 +471,14 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, DWORD but_change, mask, flags = event->dwEventFlags; int i; + /* Mouse didn't move unless MOUSE_MOVED says it did. */ + struct frame *f = get_frame (); + f->mouse_moved = 0; + switch (flags) { case MOUSE_MOVED: { - struct frame *f = get_frame (); Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); int mx = event->dwMousePosition.X, my = event->dwMousePosition.Y; @@ -533,7 +537,6 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, case MOUSE_WHEELED: case MOUSE_HWHEELED: { - struct frame *f = get_frame (); /* Mouse positions in console wheel events are reported to ReadConsoleInput relative to the display's top-left corner(!), not relative to the origin of the console screen @@ -585,8 +588,8 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, int x = event->dwMousePosition.X; int y = event->dwMousePosition.Y; - struct frame *f = get_frame (); - emacs_ev->arg = tty_handle_tab_bar_click (f, x, y, (button_state & mask) != 0, + emacs_ev->arg = tty_handle_tab_bar_click (f, x, y, + (button_state & mask) != 0, emacs_ev); emacs_ev->modifiers |= ((button_state & mask) diff --git a/src/xdisp.c b/src/xdisp.c index 5b67bcf5dce..0b8b5a41e8c 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -822,6 +822,9 @@ bool help_echo_showing_p; /* Functions to mark elements as needing redisplay. */ enum { REDISPLAY_SOME = 2}; /* Arbitrary choice. */ +static bool calc_pixel_width_or_height (double *, struct it *, Lisp_Object, + struct font *, bool, int *); + void redisplay_other_windows (void) { @@ -1282,8 +1285,8 @@ window_box_height (struct window *w) if (ml_row && ml_row->mode_line_p) height -= ml_row->height; else - height -= estimate_mode_line_height (f, - CURRENT_MODE_LINE_FACE_ID (w)); + height -= estimate_mode_line_height + (f, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w)); } } @@ -1688,7 +1691,7 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, = window_parameter (w, Qmode_line_format); w->mode_line_height - = display_mode_line (w, CURRENT_MODE_LINE_FACE_ID (w), + = display_mode_line (w, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w), NILP (window_mode_line_format) ? BVAR (current_buffer, mode_line_format) : window_mode_line_format); @@ -1998,7 +2001,17 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, } *x = top_x; - *y = max (top_y + max (0, it.max_ascent - it.ascent), window_top_y); + /* The condition below is a heuristic fix for the situation + where move_it_to stops just after finishing the display + of a fringe bitmap, which resets it.ascent to zero, and + thus causes Y to be offset by it.max_ascent. */ + if (it.ascent == 0 && it.what == IT_IMAGE + && it.method != GET_FROM_IMAGE + && it.image_id < 0 + && it.max_ascent > 0) + *y = max (top_y, window_top_y); + else + *y = max (top_y + max (0, it.max_ascent - it.ascent), window_top_y); *rtop = max (0, window_top_y - top_y); *rbot = max (0, bottom_y - it.last_visible_y); *rowh = max (0, (min (bottom_y, it.last_visible_y) @@ -2026,7 +2039,13 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, RESTORE_IT (&it2, &it2, it2data); move_it_to (&it2, charpos, -1, -1, -1, MOVE_TO_POS); *x = it2.current_x; - *y = it2.current_y + it2.max_ascent - it2.ascent; + if (it2.ascent == 0 && it2.what == IT_IMAGE + && it2.method != GET_FROM_IMAGE + && it2.image_id < 0 + && it2.max_ascent > 0) + *y = it2.current_y; + else + *y = it2.current_y + it2.max_ascent - it2.ascent; *rtop = max (0, -it2.current_y); *rbot = max (0, ((it2.current_y + it2.max_ascent + it2.max_descent) - it.last_visible_y)); @@ -3127,11 +3146,11 @@ CHECK_WINDOW_END (struct window *w) will produce glyphs in that row. BASE_FACE_ID is the id of a base face to use. It must be one of - DEFAULT_FACE_ID for normal text, MODE_LINE_FACE_ID, + DEFAULT_FACE_ID for normal text, MODE_LINE_ACTIVE_FACE_ID, MODE_LINE_INACTIVE_FACE_ID, or HEADER_LINE_FACE_ID for displaying mode lines, or TOOL_BAR_FACE_ID for displaying the tool-bar. - If ROW is null and BASE_FACE_ID is equal to MODE_LINE_FACE_ID, + If ROW is null and BASE_FACE_ID is equal to MODE_LINE_ACTIVE_FACE_ID, MODE_LINE_INACTIVE_FACE_ID, or HEADER_LINE_FACE_ID, the iterator will be initialized to use the corresponding mode line glyph row of the desired matrix of W. */ @@ -3177,7 +3196,7 @@ init_iterator (struct it *it, struct window *w, appropriate. */ if (row == NULL) { - if (base_face_id == MODE_LINE_FACE_ID + if (base_face_id == MODE_LINE_ACTIVE_FACE_ID || base_face_id == MODE_LINE_INACTIVE_FACE_ID) row = MATRIX_MODE_LINE_ROW (w->desired_matrix); else if (base_face_id == TAB_LINE_FACE_ID) @@ -5141,6 +5160,161 @@ setup_for_ellipsis (struct it *it, int len) it->ellipsis_p = true; } + +static Lisp_Object +find_display_property (Lisp_Object disp, Lisp_Object prop) +{ + if (NILP (disp)) + return Qnil; + /* We have a vector of display specs. */ + if (VECTORP (disp)) + { + for (ptrdiff_t i = 0; i < ASIZE (disp); i++) + { + Lisp_Object elem = AREF (disp, i); + if (CONSP (elem) + && CONSP (XCDR (elem)) + && EQ (XCAR (elem), prop)) + return XCAR (XCDR (elem)); + } + return Qnil; + } + /* We have a list of display specs. */ + else if (CONSP (disp) + && CONSP (XCAR (disp))) + { + while (!NILP (disp)) + { + Lisp_Object elem = XCAR (disp); + if (CONSP (elem) + && CONSP (XCDR (elem)) + && EQ (XCAR (elem), prop)) + return XCAR (XCDR (elem)); + + /* Check that we have a proper list before going to the next + element. */ + if (CONSP (XCDR (disp))) + disp = XCDR (disp); + else + disp = Qnil; + } + return Qnil; + } + /* A simple display spec. */ + else if (CONSP (disp) + && CONSP (XCDR (disp)) + && EQ (XCAR (disp), prop)) + return XCAR (XCDR (disp)); + else + return Qnil; +} + +static +Lisp_Object get_display_property (ptrdiff_t bufpos, Lisp_Object prop, + Lisp_Object object) +{ + return find_display_property (Fget_text_property (make_fixnum (bufpos), + Qdisplay, object), + prop); +} + +static void +display_min_width (struct it *it, ptrdiff_t bufpos, + Lisp_Object object, Lisp_Object width_spec) +{ + /* We're being called at the end of the `min-width' sequence, + probably. */ + if (!NILP (it->min_width_property) + && !EQ (width_spec, it->min_width_property)) + { + if (!it->glyph_row) + return; + + /* When called from display_string (i.e., the mode line), + we're being called with a string as the object, and we + may be called with many sub-strings belonging to the same + :propertize run. */ + if ((bufpos == 0 + && !EQ (it->min_width_property, + get_display_property (0, Qmin_width, object))) + /* In a buffer -- check that we're really right after the + sequence of characters covered by this `min-width'. */ + || (bufpos > BEGV + && EQ (it->min_width_property, + get_display_property (bufpos - 1, Qmin_width, object)))) + { + Lisp_Object w = Qnil; + double width; +#ifdef HAVE_WINDOW_SYSTEM + if (FRAME_WINDOW_P (it->f)) + { + struct font *font = NULL; + struct face *face = FACE_FROM_ID (it->f, it->face_id); + font = face->font ? face->font : FRAME_FONT (it->f); + calc_pixel_width_or_height (&width, it, + XCAR (it->min_width_property), + font, true, NULL); + width -= it->current_x - it->min_width_start; + w = list1 (make_int (width)); + } + else +#endif + { + calc_pixel_width_or_height (&width, it, + XCAR (it->min_width_property), + NULL, true, NULL); + width -= (it->current_x - it->min_width_start) / + FRAME_COLUMN_WIDTH (it->f); + w = make_int (width); + } + + /* Insert the stretch glyph. */ + it->object = list3 (Qspace, QCwidth, w); + produce_stretch_glyph (it); + it->min_width_property = Qnil; + } + } + + /* We're at the start of a `min-width' sequence -- record the + position and the property, so that we can later see if we're at + the end. */ + if (CONSP (width_spec)) + { + if (bufpos == BEGV + /* Mode line (see above). */ + || (bufpos == 0 + && !EQ (it->min_width_property, + get_display_property (0, Qmin_width, object))) + /* Buffer. */ + || (bufpos > BEGV + && !EQ (width_spec, + get_display_property (bufpos - 1, Qmin_width, object)))) + { + it->min_width_property = width_spec; + it->min_width_start = it->current_x; + } + } +} + +DEFUN ("get-display-property", Fget_display_property, + Sget_display_property, 2, 4, 0, + doc: /* Get the value of the `display' property PROP at POSITION. +If OBJECT, this should be a buffer or string where the property is +fetched from. If omitted, OBJECT defaults to the current buffer. + +If PROPERTIES, look for value of PROP in PROPERTIES instead of the +properties at POSITION. */) + (Lisp_Object position, Lisp_Object prop, Lisp_Object object, + Lisp_Object properties) +{ + if (NILP (properties)) + properties = Fget_text_property (position, Qdisplay, object); + else + CHECK_LIST (properties); + + return find_display_property (properties, prop); +} + /*********************************************************************** @@ -5187,16 +5361,22 @@ handle_display_prop (struct it *it) if (!it->string_from_display_prop_p) it->area = TEXT_AREA; + if (!STRINGP (it->string)) + object = it->w->contents; + propval = get_char_property_and_overlay (make_fixnum (position->charpos), Qdisplay, object, &overlay); + + /* Handle min-width ends. */ + if (!NILP (it->min_width_property) + && NILP (find_display_property (propval, Qmin_width))) + display_min_width (it, bufpos, object, Qnil); + if (NILP (propval)) return HANDLED_NORMALLY; /* Now OVERLAY is the overlay that gave us this property, or nil if it was a text property. */ - if (!STRINGP (it->string)) - object = it->w->contents; - display_replaced = handle_display_spec (it, propval, object, overlay, position, bufpos, FRAME_WINDOW_P (it->f)); @@ -5250,6 +5430,7 @@ handle_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, && !(CONSP (XCAR (spec)) && EQ (XCAR (XCAR (spec)), Qmargin)) && !EQ (XCAR (spec), Qleft_fringe) && !EQ (XCAR (spec), Qright_fringe) + && !EQ (XCAR (spec), Qmin_width) && !NILP (XCAR (spec))) { for (; CONSP (spec); spec = XCDR (spec)) @@ -5483,6 +5664,17 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, return 0; } + /* Handle `(min-width (WIDTH))'. */ + if (CONSP (spec) + && EQ (XCAR (spec), Qmin_width) + && CONSP (XCDR (spec)) + && CONSP (XCAR (XCDR (spec)))) + { + if (it) + display_min_width (it, bufpos, object, XCAR (XCDR (spec))); + return 0; + } + /* Handle `(slice X Y WIDTH HEIGHT)'. */ if (CONSP (spec) && EQ (XCAR (spec), Qslice)) @@ -7186,6 +7378,7 @@ reseat_1 (struct it *it, struct text_pos pos, bool set_stop_p) } /* This make the information stored in it->cmp_it invalidate. */ it->cmp_it.id = -1; + it->min_width_property = Qnil; } @@ -10626,77 +10819,21 @@ in_display_vector_p (struct it *it) && it->dpvec + it->current.dpvec_index != it->dpend); } -DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 6, 0, - doc: /* Return the size of the text of WINDOW's buffer in pixels. -WINDOW can be any live window and defaults to the selected one. The -return value is a cons of the maximum pixel-width of any text line -and the pixel-height of all the text lines in the accessible portion -of buffer text. -WINDOW can also be a buffer, in which case the selected window is used, -and the function behaves as if that window was displaying this buffer. - -This function exists to allow Lisp programs to adjust the dimensions -of WINDOW to the buffer text it needs to display. - -The optional argument FROM, if non-nil, specifies the first text -position to consider, and defaults to the minimum accessible position -of the buffer. If FROM is t, it stands for the minimum accessible -position that starts a non-empty line. TO, if non-nil, specifies the -last text position and defaults to the maximum accessible position of -the buffer. If TO is t, it stands for the maximum accessible position -that ends a non-empty line. - -The optional argument X-LIMIT, if non-nil, specifies the maximum X -coordinate beyond which the text should be ignored. It is therefore -also the maximum width that the function can return. X-LIMIT nil or -omitted means to use the pixel-width of WINDOW's body. This default -means text of truncated lines wider than the window will be ignored; -specify a large value for X-LIMIT if lines are truncated and you need -to account for the truncated text. Use nil for X-LIMIT if you want to -know how high WINDOW should become in order to fit all of its buffer's -text with the width of WINDOW unaltered. Use the maximum width WINDOW -may assume if you intend to change WINDOW's width. Since calculating -the width of long lines can take some time, it's always a good idea to -make this argument as small as possible; in particular, if the buffer -contains long lines that shall be truncated anyway. - -The optional argument Y-LIMIT, if non-nil, specifies the maximum Y -coordinate beyond which the text is to be ignored; it is therefore -also the maximum height that the function can return (excluding the -height of the mode- or header-line, if any). Y-LIMIT nil or omitted -means consider all of the accessible portion of buffer text up to the -position specified by TO. Since calculating the text height of a -large buffer can take some time, it makes sense to specify this -argument if the size of the buffer is large or unknown. - -Optional argument MODE-LINES nil or omitted means do not include the -height of the mode-, tab- or header-line of WINDOW in the return value. -If it is the symbol `mode-line', 'tab-line' or `header-line', include -only the height of that line, if present, in the return value. If t, -include the height of any of these, if present, in the return value. */) - (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, - Lisp_Object y_limit, Lisp_Object mode_lines) +/* This is like Fwindow_text_pixel_size but assumes that WINDOW's buffer + is the current buffer. Fbuffer_text_pixel_size calls it after it has + set WINDOW's buffer to the buffer specified by its BUFFER_OR_NAME + argument. */ +static Lisp_Object +window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, + Lisp_Object y_limit, Lisp_Object mode_lines) { - struct window *w = BUFFERP (window) ? XWINDOW (selected_window) - : decode_live_window (window); - Lisp_Object buffer = BUFFERP (window) ? window : w->contents; - struct buffer *b; + struct window *w = decode_live_window (window); struct it it; - struct buffer *old_b = NULL; ptrdiff_t start, end, bpos; struct text_pos startp; void *itdata = NULL; int c, max_x = 0, max_y = 0, x = 0, y = 0; - CHECK_BUFFER (buffer); - b = XBUFFER (buffer); - - if (b != current_buffer) - { - old_b = current_buffer; - set_buffer_internal (b); - } - if (NILP (from)) { start = BEGV; @@ -10755,8 +10892,10 @@ include the height of any of these, if present, in the return value. */) else end = clip_to_bounds (start, fix_position (to), ZV); - if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX)) + if (RANGED_FIXNUMP (0, x_limit, INT_MAX)) max_x = XFIXNUM (x_limit); + else if (!NILP (x_limit)) + max_x = INT_MAX; if (NILP (y_limit)) max_y = INT_MAX; @@ -10881,7 +11020,7 @@ include the height of any of these, if present, in the return value. */) Lisp_Object window_mode_line_format = window_parameter (w, Qmode_line_format); - y = y + display_mode_line (w, CURRENT_MODE_LINE_FACE_ID (w), + y = y + display_mode_line (w, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w), NILP (window_mode_line_format) ? BVAR (current_buffer, mode_line_format) : window_mode_line_format); @@ -10889,12 +11028,129 @@ include the height of any of these, if present, in the return value. */) bidi_unshelve_cache (itdata, false); - if (old_b) - set_buffer_internal (old_b); - return Fcons (make_fixnum (x - start_x), make_fixnum (y)); } +DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 6, 0, + doc: /* Return the size of the text of WINDOW's buffer in pixels. +WINDOW must be a live window and defaults to the selected one. The +return value is a cons of the maximum pixel-width of any text line +and the pixel-height of all the text lines in the accessible portion +of buffer text. + +This function exists to allow Lisp programs to adjust the dimensions +of WINDOW to the buffer text it needs to display. + +The optional argument FROM, if non-nil, specifies the first text +position to consider, and defaults to the minimum accessible position +of the buffer. If FROM is t, it stands for the minimum accessible +position that starts a non-empty line. TO, if non-nil, specifies the +last text position and defaults to the maximum accessible position of +the buffer. If TO is t, it stands for the maximum accessible position +that ends a non-empty line. + +The optional argument X-LIMIT, if non-nil, specifies the maximum X +coordinate beyond which the text should be ignored. It is therefore +also the maximum width that the function can return. X-LIMIT nil or +omitted means to use the pixel-width of WINDOW's body. This default +means text of truncated lines wider than the window will be ignored; +specify a non-nil value for X-LIMIT if lines are truncated and you need +to account for the truncated text. + +Use nil for X-LIMIT if you want to know how high WINDOW should become in +order to fit all of its buffer's text with the width of WINDOW +unaltered. Use the maximum width WINDOW may assume if you intend to +change WINDOW's width. Use t for the maximum possible value. Since +calculating the width of long lines can take some time, it's always a +good idea to make this argument as small as possible; in particular, if +the buffer contains long lines that shall be truncated anyway. + +The optional argument Y-LIMIT, if non-nil, specifies the maximum Y +coordinate beyond which the text is to be ignored; it is therefore +also the maximum height that the function can return (excluding the +height of the mode- or header-line, if any). Y-LIMIT nil or omitted +means consider all of the accessible portion of buffer text up to the +position specified by TO. Since calculating the text height of a +large buffer can take some time, it makes sense to specify this +argument if the size of the buffer is large or unknown. + +Optional argument MODE-LINES nil or omitted means do not include the +height of the mode-, tab- or header-line of WINDOW in the return value. +If it is the symbol `mode-line', 'tab-line' or `header-line', include +only the height of that line, if present, in the return value. If t, +include the height of any of these, if present, in the return value. */) + (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, + Lisp_Object y_limit, Lisp_Object mode_lines) +{ + struct window *w = decode_live_window (window); + struct buffer *b = XBUFFER (w->contents); + struct buffer *old_b = NULL; + Lisp_Object value; + + if (b != current_buffer) + { + old_b = current_buffer; + set_buffer_internal_1 (b); + } + + value = window_text_pixel_size (window, from, to, x_limit, y_limit, mode_lines); + + if (old_b) + set_buffer_internal_1 (old_b); + + return value; +} + +DEFUN ("buffer-text-pixel-size", Fbuffer_text_pixel_size, Sbuffer_text_pixel_size, 0, 4, 0, + doc: /* Return size of whole text of BUFFER-OR-NAME in WINDOW. +BUFFER-OR-NAME must specify a live buffer or the name of a live buffer +and defaults to the current buffer. WINDOW must be a live window and +defaults to the selected one. The return value is a cons of the maximum +pixel-width of any text line and the pixel-height of all the text lines +of the buffer specified by BUFFER-OR-NAME. + +The optional arguments X-LIMIT and Y-LIMIT have the same meaning as with +`window-text-pixel-size'. + +Do not use this function if the buffer specified by BUFFER-OR-NAME is +already displayed in WINDOW. `window-text-pixel-size' is cheaper in +that case because it does not have to temporarily show that buffer in +WINDOW. */) + (Lisp_Object buffer_or_name, Lisp_Object window, Lisp_Object x_limit, + Lisp_Object y_limit) +{ + struct window *w = decode_live_window (window); + struct buffer *b = (NILP (buffer_or_name) + ? current_buffer + : XBUFFER (Fget_buffer (buffer_or_name))); + Lisp_Object buffer, value; + ptrdiff_t count = SPECPDL_INDEX (); + + XSETBUFFER (buffer, b); + + /* The unwind form of with_echo_area_buffer is what we need here to + make WINDOW temporarily show our buffer. */ + /* FIXME: Can we move this into the `if (!EQ (buffer, w->contents))`? */ + record_unwind_protect (unwind_with_echo_area_buffer, + with_echo_area_buffer_unwind_data (w)); + + set_buffer_internal_1 (b); + + if (!EQ (buffer, w->contents)) + { + wset_buffer (w, buffer); + set_marker_both (w->pointm, buffer, BEG, BEG_BYTE); + set_marker_both (w->old_pointm, buffer, BEG, BEG_BYTE); + } + + value = window_text_pixel_size (window, Qnil, Qnil, x_limit, y_limit, Qnil); + + unbind_to (count, Qnil); + + return value; +} + + DEFUN ("display--line-is-continued-p", Fdisplay__line_is_continued_p, Sdisplay__line_is_continued_p, 0, 0, 0, doc: /* Return non-nil if the current screen line is continued on display. */) @@ -15657,6 +15913,11 @@ redisplay_internal (void) } #endif +#if defined (HAVE_HAIKU) + if (popup_activated_p) + return; +#endif + /* I don't think this happens but let's be paranoid. */ if (redisplaying_p) return; @@ -25252,6 +25513,11 @@ display_menu_bar (struct window *w) return; #endif /* HAVE_NS */ +#ifdef HAVE_HAIKU + if (FRAME_HAIKU_P (f)) + return; +#endif /* HAVE_HAIKU */ + #if defined (USE_X_TOOLKIT) || defined (USE_GTK) eassert (!FRAME_WINDOW_P (f)); init_iterator (&it, w, -1, -1, f->desired_matrix->rows, MENU_FACE_ID); @@ -25552,7 +25818,8 @@ display_mode_lines (struct window *w) struct window *sel_w = XWINDOW (old_selected_window); /* Select mode line face based on the real selected window. */ - display_mode_line (w, CURRENT_MODE_LINE_FACE_ID_3 (sel_w, sel_w, w), + display_mode_line (w, + CURRENT_MODE_LINE_ACTIVE_FACE_ID_3 (sel_w, sel_w, w), NILP (window_mode_line_format) ? BVAR (current_buffer, mode_line_format) : window_mode_line_format); @@ -25591,11 +25858,11 @@ display_mode_lines (struct window *w) } -/* Display mode or header/tab line of window W. FACE_ID specifies which - line to display; it is either MODE_LINE_FACE_ID, HEADER_LINE_FACE_ID or - TAB_LINE_FACE_ID. FORMAT is the mode/header/tab line format to - display. Value is the pixel height of the mode/header/tab line - displayed. */ +/* Display mode or header/tab line of window W. FACE_ID specifies + which line to display; it is either MODE_LINE_ACTIVE_FACE_ID, + HEADER_LINE_FACE_ID or TAB_LINE_FACE_ID. FORMAT is the + mode/header/tab line format to display. Value is the pixel height + of the mode/header/tab line displayed. */ static int display_mode_line (struct window *w, enum face_id face_id, Lisp_Object format) @@ -26388,8 +26655,8 @@ are the selected window and the WINDOW's buffer). */) face_id = (NILP (face) || EQ (face, Qdefault)) ? DEFAULT_FACE_ID : EQ (face, Qt) ? (EQ (window, selected_window) - ? MODE_LINE_FACE_ID : MODE_LINE_INACTIVE_FACE_ID) - : EQ (face, Qmode_line) ? MODE_LINE_FACE_ID + ? MODE_LINE_ACTIVE_FACE_ID : MODE_LINE_INACTIVE_FACE_ID) + : EQ (face, Qmode_line_active) ? MODE_LINE_ACTIVE_FACE_ID : EQ (face, Qmode_line_inactive) ? MODE_LINE_INACTIVE_FACE_ID : EQ (face, Qheader_line) ? HEADER_LINE_FACE_ID : EQ (face, Qtab_line) ? TAB_LINE_FACE_ID @@ -29959,7 +30226,7 @@ append_stretch_glyph (struct it *it, Lisp_Object object, #endif /* HAVE_WINDOW_SYSTEM */ /* Produce a stretch glyph for iterator IT. IT->object is the value - of the glyph property displayed. The value must be a list + of the display property. The value must be a list of the form `(space KEYWORD VALUE ...)' with the following KEYWORD/VALUE pairs being recognized: @@ -29969,7 +30236,7 @@ append_stretch_glyph (struct it *it, Lisp_Object object, 2. `:relative-width FACTOR' specifies that the width of the stretch should be computed from the width of the first character having the - `glyph' property, and should be FACTOR times that width. + `display' property, and should be FACTOR times that width. 3. `:align-to HPOS' specifies that the space should be wide enough to reach HPOS, a value in canonical character units. @@ -29981,7 +30248,7 @@ append_stretch_glyph (struct it *it, Lisp_Object object, 5. `:relative-height FACTOR' specifies that the height of the stretch should be FACTOR times the height of the characters having - the glyph property. + the display property. Either none or exactly one of 4 or 5 must be present. @@ -30002,10 +30269,11 @@ produce_stretch_glyph (struct it *it) #ifdef HAVE_WINDOW_SYSTEM int ascent = 0; bool zero_height_ok_p = false; + struct face *face = NULL; /* shut up GCC's -Wmaybe-uninitialized */ if (FRAME_WINDOW_P (it->f)) { - struct face *face = FACE_FROM_ID (it->f, it->face_id); + face = FACE_FROM_ID (it->f, it->face_id); font = face->font ? face->font : FRAME_FONT (it->f); prepare_face_for_display (it->f, face); } @@ -30026,14 +30294,27 @@ produce_stretch_glyph (struct it *it) else if (prop = Fplist_get (plist, QCrelative_width), NUMVAL (prop) > 0) { /* Relative width `:relative-width FACTOR' specified and valid. - Compute the width of the characters having the `glyph' + Compute the width of the characters having this `display' property. */ struct it it2; - unsigned char *p = BYTE_POS_ADDR (IT_BYTEPOS (*it)); + Lisp_Object object = it->stack[it->sp - 1].string; + unsigned char *p = (STRINGP (object) + ? SDATA (object) + IT_STRING_BYTEPOS (*it) + : BYTE_POS_ADDR (IT_BYTEPOS (*it))); + bool multibyte_p = + STRINGP (object) ? STRING_MULTIBYTE (object) : it->multibyte_p; it2 = *it; - if (it->multibyte_p) - it2.c = it2.char_to_display = string_char_and_length (p, &it2.len); + if (multibyte_p) + { + it2.c = it2.char_to_display = string_char_and_length (p, &it2.len); +#ifdef HAVE_WINDOW_SYSTEM + if (FRAME_WINDOW_P (it->f) && ! ASCII_CHAR_P (it2.c)) + it2.face_id = FACE_FOR_CHAR (it->f, face, it2.c, + IT_CHARPOS (*it), + STRINGP (object)? object : Qnil); +#endif + } else { it2.c = it2.char_to_display = *p, it2.len = 1; @@ -30933,6 +31214,11 @@ gui_produce_glyphs (struct it *it) it->max_ascent = max (it->max_ascent, font_ascent); it->max_descent = max (it->max_descent, font_descent); } + + if (it->ascent < 0) + it->ascent = 0; + if (it->descent < 0) + it->descent = 0; } else if (it->what == IT_COMPOSITION && it->cmp_it.ch < 0) { @@ -33713,6 +33999,11 @@ note_mouse_highlight (struct frame *f, int x, int y) return; #endif +#if defined (HAVE_HAIKU) + if (popup_activated_p) + return; +#endif + if (!f->glyphs_initialized_p || f->pointer_invisible) return; @@ -35040,9 +35331,11 @@ be let-bound around code that needs to disable messages temporarily. */); defsubr (&Sinvisible_p); defsubr (&Scurrent_bidi_paragraph_direction); defsubr (&Swindow_text_pixel_size); + defsubr (&Sbuffer_text_pixel_size); defsubr (&Smove_point_visually); defsubr (&Sbidi_find_overridden_directionality); defsubr (&Sdisplay__line_is_continued_p); + defsubr (&Sget_display_property); DEFSYM (Qmenu_bar_update_hook, "menu-bar-update-hook"); DEFSYM (Qoverriding_terminal_local_map, "overriding-terminal-local-map"); @@ -35385,7 +35678,9 @@ line number may be omitted from the mode line. */); line_number_display_limit_width = 200; DEFVAR_BOOL ("highlight-nonselected-windows", highlight_nonselected_windows, - doc: /* Non-nil means highlight region even in nonselected windows. */); + doc: /* Non-nil means highlight active region even in nonselected windows. +When nil (the default), the active region is only highlighted when +the window is selected. */); highlight_nonselected_windows = false; DEFVAR_BOOL ("multiple-frames", multiple_frames, @@ -35949,11 +36244,13 @@ message displayed by its counterpart function specified by Vclear_message_function = Qnil; DEFVAR_LISP ("redisplay--all-windows-cause", Vredisplay__all_windows_cause, - doc: /* */); + doc: /* Code of the cause for redisplaying all windows. +Internal use only. */); Vredisplay__all_windows_cause = Fmake_hash_table (0, NULL); DEFVAR_LISP ("redisplay--mode-lines-cause", Vredisplay__mode_lines_cause, - doc: /* */); + doc: /* Code of the cause for redisplaying mode lines. +Internal use only. */); Vredisplay__mode_lines_cause = Fmake_hash_table (0, NULL); DEFVAR_BOOL ("redisplay--inhibit-bidi", redisplay__inhibit_bidi, @@ -35979,10 +36276,11 @@ mouse stays within the extent of a single glyph (except for images). */); tab_bar__dragging_in_progress = false; DEFVAR_BOOL ("redisplay-skip-initial-frame", redisplay_skip_initial_frame, - doc: /* Non-nil to skip redisplay in initial frame. -The initial frame is not displayed anywhere, so skipping it is -best except in special circumstances such as running redisplay tests -in batch mode. */); + doc: /* Non-nil means skip redisplay of the initial frame. +The initial frame is the text-mode frame used by Emacs internally during +the early stages of startup. That frame is not displayed anywhere, so +skipping it is best except in special circumstances such as running +redisplay tests in batch mode. */); redisplay_skip_initial_frame = true; DEFVAR_BOOL ("redisplay-skip-fontification-on-input", diff --git a/src/xfaces.c b/src/xfaces.c index 86ee18cd44a..6f52637e916 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -249,7 +249,11 @@ along with GNU Emacs. If not, see . */ #ifdef HAVE_PGTK #define GCGraphicsExposures 0 -#endif /* HAVE_NS */ +#endif /* HAVE_PGTK */ + +#ifdef HAVE_HAIKU +#define GCGraphicsExposures 0 +#endif /* HAVE_HAIKU */ #endif /* HAVE_WINDOW_SYSTEM */ #include "buffer.h" @@ -559,8 +563,8 @@ x_free_gc (struct frame *f, Emacs_GC *gc) #endif /* HAVE_NTGUI */ -#ifdef HAVE_NS -/* NS emulation of GCs */ +#if defined (HAVE_NS) || defined (HAVE_HAIKU) +/* NS and Haiku emulation of GCs */ static Emacs_GC * x_create_gc (struct frame *f, @@ -4861,7 +4865,7 @@ lookup_named_face (struct window *w, struct frame *f, /* Return the display face-id of the basic face whose canonical face-id is FACE_ID. The return value will usually simply be FACE_ID, unless that - basic face has bee remapped via Vface_remapping_alist. This function is + basic face has been remapped via Vface_remapping_alist. This function is conservative: if something goes wrong, it will simply return FACE_ID rather than signal an error. Window W, if non-NULL, is used to filter face specifications for remapping. */ @@ -4877,7 +4881,7 @@ lookup_basic_face (struct window *w, struct frame *f, int face_id) switch (face_id) { case DEFAULT_FACE_ID: name = Qdefault; break; - case MODE_LINE_FACE_ID: name = Qmode_line; break; + case MODE_LINE_ACTIVE_FACE_ID: name = Qmode_line_active; break; case MODE_LINE_INACTIVE_FACE_ID: name = Qmode_line_inactive; break; case HEADER_LINE_FACE_ID: name = Qheader_line; break; case TAB_LINE_FACE_ID: name = Qtab_line; break; @@ -5589,6 +5593,7 @@ realize_basic_faces (struct frame *f) if (realize_default_face (f)) { realize_named_face (f, Qmode_line, MODE_LINE_FACE_ID); + realize_named_face (f, Qmode_line_active, MODE_LINE_ACTIVE_FACE_ID); realize_named_face (f, Qmode_line_inactive, MODE_LINE_INACTIVE_FACE_ID); realize_named_face (f, Qtool_bar, TOOL_BAR_FACE_ID); realize_named_face (f, Qfringe, FRINGE_FACE_ID); @@ -6392,20 +6397,19 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, int face_id; if (base_face_id >= 0) - { - face_id = base_face_id; - /* Make sure the base face ID is usable: if someone freed the - cached faces since we've looked up the base face, we need - to look it up again. */ - if (!FACE_FROM_ID_OR_NULL (f, face_id)) - face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); - } + face_id = base_face_id; else if (NILP (Vface_remapping_alist)) face_id = DEFAULT_FACE_ID; else face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); - default_face = FACE_FROM_ID (f, face_id); + default_face = FACE_FROM_ID_OR_NULL (f, face_id); + /* Make sure the default face ID is usable: if someone freed the + cached faces since we've looked up these faces, we need to look + them up again. */ + if (!default_face) + default_face = FACE_FROM_ID (f, + lookup_basic_face (w, f, DEFAULT_FACE_ID)); } /* Optimize common cases where we can use the default face. */ @@ -6590,7 +6594,9 @@ face_at_string_position (struct window *w, Lisp_Object string, else *endptr = -1; - base_face = FACE_FROM_ID (f, base_face_id); + base_face = FACE_FROM_ID_OR_NULL (f, base_face_id); + if (!base_face) + base_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID)); /* Optimize the default case that there is no face property. */ if (NILP (prop) @@ -6964,6 +6970,7 @@ syms_of_xfaces (void) DEFSYM (Qborder, "border"); DEFSYM (Qmouse, "mouse"); DEFSYM (Qmode_line_inactive, "mode-line-inactive"); + DEFSYM (Qmode_line_active, "mode-line-active"); DEFSYM (Qvertical_border, "vertical-border"); DEFSYM (Qwindow_divider, "window-divider"); DEFSYM (Qwindow_divider_first_pixel, "window-divider-first-pixel"); diff --git a/src/xfns.c b/src/xfns.c index 785ae3baca5..5eff9f5b0f8 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -57,6 +57,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XINPUT2 +#include +#endif + #ifdef USE_X_TOOLKIT #include @@ -2912,6 +2916,44 @@ initial_set_up_x_back_buffer (struct frame *f) unblock_input (); } +#if defined HAVE_XINPUT2 && !defined USE_GTK +static void +setup_xi_event_mask (struct frame *f) +{ + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_KeyPress); + XISetMask (m, XI_KeyRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + XISetMask (m, XI_FocusIn); + XISetMask (m, XI_FocusOut); + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + + memset (m, 0, l); + mask.deviceid = XIAllDevices; + + XISetMask (m, XI_PropertyEvent); + XISetMask (m, XI_HierarchyChanged); + XISetMask (m, XI_DeviceChanged); + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); +} +#endif + #ifdef USE_X_TOOLKIT /* Create and set up the X widget for frame F. */ @@ -3074,6 +3116,11 @@ x_window (struct frame *f, long window_prompting) class_hints.res_class = SSDATA (Vx_resource_class); XSetClassHint (FRAME_X_DISPLAY (f), XtWindow (shell_widget), &class_hints); +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + setup_xi_event_mask (f); +#endif + #ifdef HAVE_X_I18N FRAME_XIC (f) = NULL; if (use_xim) @@ -3254,6 +3301,11 @@ x_window (struct frame *f) } #endif /* HAVE_X_I18N */ +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + setup_xi_event_mask (f); +#endif + validate_x_resource_name (); class_hints.res_name = SSDATA (Vx_resource_name); @@ -4416,7 +4468,8 @@ For GNU and Unix system, the first 2 numbers are the version of the X Protocol used on TERMINAL and the 3rd number is the distributor-specific release number. For MS Windows, the 3 numbers report the OS major and minor version and build number. For Nextstep, the first 2 numbers are -hard-coded and the 3rd represents the OS version. +hard-coded and the 3rd represents the OS version. For Haiku, all 3 +numbers are hard-coded. See also the function `x-server-vendor'. @@ -7374,7 +7427,7 @@ Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file selection box, if specified. If MUSTMATCH is non-nil, the returned file or directory must exist. -This function is defined only on NS, MS Windows, and X Windows with the +This function is defined only on NS, Haiku, MS Windows, and X Windows with the Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored. Otherwise, if ONLY-DIR-P is non-nil, the user can select only directories. On MS Windows 7 and later, the file selection dialog "remembers" the last @@ -8038,6 +8091,12 @@ eliminated in future versions of Emacs. */); /* Tell Emacs about this window system. */ Fprovide (Qx, Qnil); +#ifdef HAVE_XINPUT2 + DEFSYM (Qxinput2, "xinput2"); + + Fprovide (Qxinput2, Qnil); +#endif + #ifdef USE_X_TOOLKIT Fprovide (intern_c_string ("x-toolkit"), Qnil); #ifdef USE_MOTIF diff --git a/src/xmenu.c b/src/xmenu.c index ea2cbab2030..07255911f97 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -105,7 +105,11 @@ along with GNU Emacs. If not, see . */ /* Flag which when set indicates a dialog or menu has been posted by Xt on behalf of one of the widget sets. */ +#ifndef HAVE_XINPUT2 static int popup_activated_flag; +#else +int popup_activated_flag; +#endif #ifdef USE_X_TOOLKIT diff --git a/src/xterm.c b/src/xterm.c index 172abe919dd..a6d9c8c7a1b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -42,6 +42,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XINPUT2 +#include +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -223,9 +227,15 @@ static bool x_handle_net_wm_state (struct frame *, const XPropertyEvent *); static void x_check_fullscreen (struct frame *); static void x_check_expected_move (struct frame *, int, int); static void x_sync_with_move (struct frame *, int, int, bool); +#ifndef HAVE_XINPUT2 static int handle_one_xevent (struct x_display_info *, const XEvent *, int *, struct input_event *); +#else +static int handle_one_xevent (struct x_display_info *, + XEvent *, int *, + struct input_event *); +#endif #if ! (defined USE_X_TOOLKIT || defined USE_MOTIF) && defined USE_GTK static int x_dispatch_event (XEvent *, Display *); #endif @@ -335,6 +345,251 @@ x_extension_initialize (struct x_display_info *dpyinfo) dpyinfo->ext_codes = ext_codes; } +#endif /* HAVE_CAIRO */ + +#ifdef HAVE_XINPUT2 + +/* Free all XI2 devices on dpyinfo. */ +static void +x_free_xi_devices (struct x_display_info *dpyinfo) +{ + block_input (); + + if (dpyinfo->num_devices) + { + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + XIUngrabDevice (dpyinfo->display, dpyinfo->devices[i].device_id, + CurrentTime); + xfree (dpyinfo->devices[i].valuators); + } + + xfree (dpyinfo->devices); + dpyinfo->devices = NULL; + dpyinfo->num_devices = 0; + } + + unblock_input (); +} + +/* The code below handles the tracking of scroll valuators on XInput + 2, in order to support scroll wheels that report information more + granular than a screen line. + + On X, when the XInput 2 extension is being utilized, the states of + the mouse wheels in each axis are stored as absolute values inside + "valuators" attached to each mouse device. To obtain the delta of + the scroll wheel from a motion event (which is used to report that + some valuator has changed), it is necessary to iterate over every + valuator that changed, and compare its previous value to the + current value of the valuator. + + Each individual valuator also has an "interval", which is the + amount you must divide that delta by in order to obtain a delta in + the terms of scroll units. + + This delta however is still intermediate, to make driver + implementations easier. The XInput developers recommend (and most + programs use) the following algorithm to convert from scroll unit + deltas to pixel deltas: + + pixels_scrolled = pow (window_height, 2.0 / 3.0) * delta; */ + +/* Setup valuator tracking for XI2 master devices on + DPYINFO->display. */ + +static void +x_init_master_valuators (struct x_display_info *dpyinfo) +{ + int ndevices; + XIDeviceInfo *infos; + + block_input (); + x_free_xi_devices (dpyinfo); + infos = XIQueryDevice (dpyinfo->display, + XIAllMasterDevices, + &ndevices); + + if (!ndevices) + { + XIFreeDeviceInfo (infos); + unblock_input (); + return; + } + + int actual_devices = 0; + dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices); + + for (int i = 0; i < ndevices; ++i) + { + XIDeviceInfo *device = &infos[i]; + + if (device->enabled) + { + int actual_valuator_count = 0; + struct xi_device_t *xi_device = &dpyinfo->devices[actual_devices++]; + xi_device->device_id = device->deviceid; + xi_device->grab = 0; + xi_device->valuators = + xmalloc (sizeof *xi_device->valuators * device->num_classes); + + for (int c = 0; c < device->num_classes; ++c) + { + switch (device->classes[c]->type) + { +#ifdef XIScrollClass /* XInput 2.1 */ + case XIScrollClass: + { + XIScrollClassInfo *info = + (XIScrollClassInfo *) device->classes[c]; + struct xi_scroll_valuator_t *valuator = + &xi_device->valuators[actual_valuator_count++]; + + valuator->horizontal + = (info->scroll_type == XIScrollTypeHorizontal); + valuator->invalid_p = true; + valuator->emacs_value = DBL_MIN; + valuator->increment = info->increment; + valuator->number = info->number; + break; + } +#endif + default: + break; + } + } + xi_device->scroll_valuator_count = actual_valuator_count; + } + } + + dpyinfo->num_devices = actual_devices; + XIFreeDeviceInfo (infos); + unblock_input (); +} + +/* Return the delta of the scroll valuator VALUATOR_NUMBER under + DEVICE_ID in the display DPYINFO with VALUE. The valuator's + valuator will be set to VALUE afterwards. In case no scroll + valuator is found, or if device_id is not known to Emacs, DBL_MAX + is returned. Otherwise, the valuator is returned in + VALUATOR_RETURN. */ +static double +x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id, + int valuator_number, double value, + struct xi_scroll_valuator_t **valuator_return) +{ + block_input (); + + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + struct xi_device_t *device = &dpyinfo->devices[i]; + + if (device->device_id == device_id) + { + for (int j = 0; j < device->scroll_valuator_count; ++j) + { + struct xi_scroll_valuator_t *sv = &device->valuators[j]; + + if (sv->number == valuator_number) + { + if (sv->invalid_p) + { + sv->current_value = value; + sv->invalid_p = false; + *valuator_return = sv; + + unblock_input (); + return 0.0; + } + else + { + double delta = (sv->current_value - value) / sv->increment; + sv->current_value = value; + *valuator_return = sv; + + unblock_input (); + return delta; + } + } + } + + unblock_input (); + return DBL_MAX; + } + } + + unblock_input (); + return DBL_MAX; +} + +static struct xi_device_t * +xi_device_from_id (struct x_display_info *dpyinfo, int deviceid) +{ + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + if (dpyinfo->devices[i].device_id == deviceid) + return &dpyinfo->devices[i]; + } + + return NULL; +} + +static void +xi_grab_or_ungrab_device (struct xi_device_t *device, + struct x_display_info *dpyinfo, + Window window) +{ + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + + if (device->grab) + { + XIGrabDevice (dpyinfo->display, device->device_id, window, + CurrentTime, None, GrabModeAsync, + GrabModeAsync, True, &mask); + } + else + { + XIUngrabDevice (dpyinfo->display, device->device_id, CurrentTime); + } +} + +static void +xi_reset_scroll_valuators_for_device_id (struct x_display_info *dpyinfo, int id) +{ + struct xi_device_t *device = xi_device_from_id (dpyinfo, id); + struct xi_scroll_valuator_t *valuator; + + if (!device) + return; + + if (!device->scroll_valuator_count) + return; + + for (int i = 0; i < device->scroll_valuator_count; ++i) + { + valuator = &device->valuators[i]; + valuator->invalid_p = true; + valuator->emacs_value = 0.0; + } + + return; +} + +#endif + +#ifdef USE_CAIRO + void x_cr_destroy_frame_context (struct frame *f) { @@ -4439,7 +4694,7 @@ x_scroll_run (struct window *w, struct run *run) int text_area_x, text_area_y, text_area_width, text_area_height; int clip_top, clip_bottom; - window_box (w, TEXT_AREA, &text_area_x, &text_area_y, + window_box (w, view->area, &text_area_x, &text_area_y, &text_area_width, &text_area_height); view->y = y; @@ -4768,7 +5023,16 @@ static struct frame * x_menubar_window_to_frame (struct x_display_info *dpyinfo, const XEvent *event) { - Window wdesc = event->xany.window; + Window wdesc; +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent + && dpyinfo->supports_xi2 + && (event->xcookie.evtype == XI_ButtonPress + || event->xcookie.evtype == XI_ButtonRelease)) + wdesc = ((XIDeviceEvent *) event->xcookie.data)->event; + else +#endif + wdesc = event->xany.window; Lisp_Object tail, frame; struct frame *f; struct x_output *x; @@ -4871,6 +5135,29 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, } break; +#ifdef HAVE_XINPUT2 + case GenericEvent: + { + XIEvent *xi_event = (XIEvent *) event; + + struct frame *focus_frame = dpyinfo->x_focus_event_frame; + int focus_state + = focus_frame ? focus_frame->output_data.x->focus_state : 0; + + if (!((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave) + && (focus_state & FOCUS_EXPLICIT))) + x_focus_changed ((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_FocusIn + ? FocusIn : FocusOut), + (xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave + ? FOCUS_IMPLICIT : FOCUS_EXPLICIT), + dpyinfo, frame, bufp); + break; + } +#endif + case FocusIn: case FocusOut: /* Ignore transient focus events from hotkeys, window manager @@ -7975,7 +8262,11 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) static int handle_one_xevent (struct x_display_info *dpyinfo, +#ifndef HAVE_XINPUT2 const XEvent *event, +#else + XEvent *event, +#endif int *finish, struct input_event *hold_quit) { union buffered_input_event inev; @@ -8001,7 +8292,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; - any = x_any_window_to_frame (dpyinfo, event->xany.window); +#ifdef HAVE_XINPUT2 + if (event->type != GenericEvent) +#endif + any = x_any_window_to_frame (dpyinfo, event->xany.window); +#ifdef HAVE_XINPUT2 + else + any = NULL; +#endif if (any && any->wait_event_type == event->type) any->wait_event_type = 0; /* Indicates we got it. */ @@ -8480,6 +8778,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto OTHER; case MapNotify: +#if defined HAVE_XINPUT2 && defined HAVE_GTK3 + if (xg_is_menu_window (dpyinfo->display, event->xmap.window)) + popup_activated_flag = 1; +#endif /* We use x_top_window_to_frame because map events can come for sub-windows and they don't mean that the frame is visible. */ @@ -9304,8 +9606,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, event->xbutton.button, event->xbutton.state, event->xbutton.time); - if (!EQ (selected_window, xvw->w)) - { + if (!EQ (selected_window, xvw->w) && (event->xbutton.button < 4)) + { inev.ie.kind = SELECT_WINDOW_EVENT; inev.ie.frame_or_window = xvw->w; } @@ -9511,6 +9813,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_find_modifier_meanings (dpyinfo); FALLTHROUGH; case MappingKeyboard: +#ifdef HAVE_XKB + if (dpyinfo->xkb_desc) + XkbGetUpdatedMap (dpyinfo->display, XkbAllComponentsMask, + dpyinfo->xkb_desc); +#endif XRefreshKeyboardMapping ((XMappingEvent *) &event->xmapping); } goto OTHER; @@ -9518,6 +9825,918 @@ handle_one_xevent (struct x_display_info *dpyinfo, case DestroyNotify: xft_settings_event (dpyinfo, event); break; +#ifdef HAVE_XINPUT2 + case GenericEvent: + { + if (!dpyinfo->supports_xi2) + goto OTHER; + if (event->xgeneric.extension != dpyinfo->xi2_opcode) + /* Not an XI2 event. */ + goto OTHER; + bool must_free_data = false; + XIEvent *xi_event = (XIEvent *) event->xcookie.data; + /* Sometimes the event is already claimed by GTK, which + will free its data in due course. */ + if (!xi_event && XGetEventData (dpyinfo->display, &event->xcookie)) + { + must_free_data = true; + xi_event = (XIEvent *) event->xcookie.data; + } + + XIDeviceEvent *xev = (XIDeviceEvent *) xi_event; + XILeaveEvent *leave = (XILeaveEvent *) xi_event; + XIEnterEvent *enter = (XIEnterEvent *) xi_event; + XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event; + XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event; + XIValuatorState *states; + double *values; + bool found_valuator = false; + + /* A fake XMotionEvent for x_note_mouse_movement. */ + XMotionEvent ev; + /* A fake XButtonEvent for x_construct_mouse_click. */ + XButtonEvent bv; + + if (!xi_event) + { + eassert (!must_free_data); + goto OTHER; + } + + switch (event->xcookie.evtype) + { + case XI_FocusIn: + any = x_any_window_to_frame (dpyinfo, focusin->event); +#ifndef USE_GTK + /* Some WMs (e.g. Mutter in Gnome Shell), don't unmap + minimized/iconified windows; thus, for those WMs we won't get + a MapNotify when unminimizing/deconifying. Check here if we + are deiconizing a window (Bug42655). + + But don't do that on GTK since it may cause a plain invisible + frame get reported as iconified, compare + https://lists.gnu.org/archive/html/emacs-devel/2017-02/msg00133.html. + That is fixed above but bites us here again. */ + f = any; + if (f && FRAME_ICONIFIED_P (f)) + { + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, false); + f->output_data.x->has_been_visible = true; + inev.ie.kind = DEICONIFY_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + } +#endif /* USE_GTK */ + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + goto XI_OTHER; + case XI_FocusOut: + any = x_any_window_to_frame (dpyinfo, focusout->event); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + goto XI_OTHER; + case XI_Enter: + any = x_any_window_to_frame (dpyinfo, enter->event); + ev.x = lrint (enter->event_x); + ev.y = lrint (enter->event_y); + ev.window = leave->event; + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + + /* One problem behind the design of XInput 2 scrolling is + that valuators are not unique to each window, but only + the window that has grabbed the valuator's device or + the window that the device's pointer is on top of can + receive motion events. There is also no way to + retrieve the value of a valuator outside of each motion + event. + + As such, to prevent wildly inaccurate results when the + valuators have changed outside Emacs, we reset our + records of each valuator's value whenever the pointer + re-enters a frame after its valuators have potentially + been changed elsewhere. */ + if (enter->detail != XINotifyInferior + && enter->mode != XINotifyPassiveUngrab + && enter->mode != XINotifyUngrab && any) + xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid); + + f = any; + + if (f && x_mouse_click_focus_ignore_position) + ignore_next_mouse_click_timeout = xi_event->time + 200; + + /* EnterNotify counts as mouse movement, + so update things that depend on mouse position. */ + if (f && !f->output_data.x->hourglass_p) + x_note_mouse_movement (f, &ev); +#ifdef USE_GTK + /* We may get an EnterNotify on the buttons in the toolbar. In that + case we moved out of any highlighted area and need to note this. */ + if (!f && dpyinfo->last_mouse_glyph_frame) + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); +#endif + goto XI_OTHER; + case XI_Leave: + ev.x = lrint (leave->event_x); + ev.y = lrint (leave->event_y); + ev.window = leave->event; + any = x_any_window_to_frame (dpyinfo, leave->event); + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + + f = x_top_window_to_frame (dpyinfo, leave->event); + if (f) + { + if (f == hlinfo->mouse_face_mouse_frame) + { + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = 0; + } + + /* Generate a nil HELP_EVENT to cancel a help-echo. + Do it only if there's something to cancel. + Otherwise, the startup message is cleared when + the mouse leaves the frame. */ + if (any_help_event_p) + do_help = -1; + } +#ifdef USE_GTK + /* See comment in EnterNotify above */ + else if (dpyinfo->last_mouse_glyph_frame) + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); +#endif + goto XI_OTHER; + case XI_Motion: + states = &xev->valuators; + values = states->values; + + x_display_set_last_user_time (dpyinfo, xi_event->time); + +#ifdef HAVE_XWIDGETS + struct xwidget_view *xv = xwidget_view_from_window (xev->event); + double xv_total_x = 0.0; + double xv_total_y = 0.0; +#endif + + for (int i = 0; i < states->mask_len * 8; i++) + { + if (XIMaskIsSet (states->mask, i)) + { + struct xi_scroll_valuator_t *val; + double delta, scroll_unit; + + + /* See the comment on top of + x_init_master_valuators for more details on how + scroll wheel movement is reported on XInput 2. */ + delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, + i, *values, &val); + + if (delta != DBL_MAX) + { +#ifdef HAVE_XWIDGETS + if (xv) + { + if (val->horizontal) + xv_total_x += delta; + else + xv_total_y += -delta; + + found_valuator = true; + continue; + } +#endif + if (!f) + { + f = x_any_window_to_frame (dpyinfo, xev->event); + + if (!f) + goto XI_OTHER; + } + + found_valuator = true; + + if (signbit (delta) != signbit (val->emacs_value)) + val->emacs_value = 0; + + val->emacs_value += delta; + + if (x_coalesce_scroll_events + && (fabs (val->emacs_value) < 1)) + continue; + + bool s = signbit (val->emacs_value); + inev.ie.kind = (val->horizontal + ? HORIZ_WHEEL_EVENT + : WHEEL_EVENT); + inev.ie.timestamp = xev->time; + + XSETINT (inev.ie.x, lrint (xev->event_x)); + XSETINT (inev.ie.y, lrint (xev->event_y)); + XSETFRAME (inev.ie.frame_or_window, f); + + inev.ie.modifiers = !s ? up_modifier : down_modifier; + inev.ie.modifiers + |= x_x_to_emacs_modifiers (dpyinfo, + xev->mods.effective); + + scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); + + if (FLOATP (Vx_scroll_event_delta_factor)) + scroll_unit *= XFLOAT_DATA (Vx_scroll_event_delta_factor); + + if (val->horizontal) + { + inev.ie.arg + = list3 (Qnil, + make_float (val->emacs_value + * scroll_unit), + make_float (0)); + } + else + { + inev.ie.arg = list3 (Qnil, make_float (0), + make_float (val->emacs_value + * scroll_unit)); + } + + kbd_buffer_store_event_hold (&inev.ie, hold_quit); + + val->emacs_value = 0; + } + values++; + } + + inev.ie.kind = NO_EVENT; + } + +#ifdef HAVE_XWIDGETS + if (xv) + { + if (found_valuator) + xwidget_scroll (xv, xev->event_x, xev->event_y, + xv_total_x, xv_total_y, xev->mods.effective, + xev->time); + else + xwidget_motion_notify (xv, xev->event_x, xev->event_y, + xev->mods.effective, xev->time); + + goto XI_OTHER; + } +#endif + if (found_valuator) + goto XI_OTHER; + + ev.x = lrint (xev->event_x); + ev.y = lrint (xev->event_y); + ev.window = xev->event; + ev.time = xev->time; + + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + if (hlinfo->mouse_face_hidden) + { + hlinfo->mouse_face_hidden = false; + clear_mouse_face (hlinfo); + } + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; +#endif + if (f) + { + /* Maybe generate a SELECT_WINDOW_EVENT for + `mouse-autoselect-window' but don't let popup menus + interfere with this (Bug#1261). */ + if (!NILP (Vmouse_autoselect_window) + && !popup_activated () + /* Don't switch if we're currently in the minibuffer. + This tries to work around problems where the + minibuffer gets unselected unexpectedly, and where + you then have to move your mouse all the way down to + the minibuffer to select it. */ + && !MINI_WINDOW_P (XWINDOW (selected_window)) + /* With `focus-follows-mouse' non-nil create an event + also when the target window is on another frame. */ + && (f == XFRAME (selected_frame) + || !NILP (focus_follows_mouse))) + { + static Lisp_Object last_mouse_window; + Lisp_Object window = window_from_coordinates (f, ev.x, ev.y, 0, false, false); + + /* A window will be autoselected only when it is not + selected now and the last mouse movement event was + not in it. The remainder of the code is a bit vague + wrt what a "window" is. For immediate autoselection, + the window is usually the entire window but for GTK + where the scroll bars don't count. For delayed + autoselection the window is usually the window's text + area including the margins. */ + if (WINDOWP (window) + && !EQ (window, last_mouse_window) + && !EQ (window, selected_window)) + { + inev.ie.kind = SELECT_WINDOW_EVENT; + inev.ie.frame_or_window = window; + } + + /* Remember the last window where we saw the mouse. */ + last_mouse_window = window; + } + + if (!x_note_mouse_movement (f, &ev)) + help_echo_string = previous_help_echo_string; + } + else + { +#ifndef USE_TOOLKIT_SCROLL_BARS + struct scroll_bar *bar + = x_window_to_scroll_bar (xi_event->display, xev->event, 2); + + if (bar) + x_scroll_bar_note_movement (bar, &ev); +#endif /* USE_TOOLKIT_SCROLL_BARS */ + + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + } + + /* If the contents of the global variable help_echo_string + has changed, generate a HELP_EVENT. */ + if (!NILP (help_echo_string) + || !NILP (previous_help_echo_string)) + do_help = 1; + goto XI_OTHER; + case XI_ButtonRelease: + case XI_ButtonPress: + { + /* If we decide we want to generate an event to be seen + by the rest of Emacs, we put it here. */ + Lisp_Object tab_bar_arg = Qnil; + bool tab_bar_p = false; + bool tool_bar_p = false; + struct xi_device_t *device; + +#ifdef XIPointerEmulated + /* Ignore emulated scroll events when XI2 native + scroll events are present. */ + if (dpyinfo->xi2_version >= 1 + && xev->detail >= 4 + && xev->detail <= 8 + && xev->flags & XIPointerEmulated) + goto XI_OTHER; +#endif + + device = xi_device_from_id (dpyinfo, xev->deviceid); + + bv.button = xev->detail; + bv.type = xev->evtype == XI_ButtonPress ? ButtonPress : ButtonRelease; + bv.x = lrint (xev->event_x); + bv.y = lrint (xev->event_y); + bv.window = xev->event; + bv.state = xev->mods.effective; + bv.time = xev->time; + + memset (&compose_status, 0, sizeof (compose_status)); + dpyinfo->last_mouse_glyph_frame = NULL; + x_display_set_last_user_time (dpyinfo, xev->time); + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + + if (f && xev->evtype == XI_ButtonPress + && !popup_activated () + && !x_window_to_scroll_bar (xev->display, xev->event, 2) + && !FRAME_NO_ACCEPT_FOCUS (f)) + { + /* When clicking into a child frame or when clicking + into a parent frame with the child frame selected and + `no-accept-focus' is not set, select the clicked + frame. */ + struct frame *hf = dpyinfo->highlight_frame; + + if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf))) + { + block_input (); + XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), + RevertToParent, CurrentTime); + if (FRAME_PARENT_FRAME (f)) + XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); + unblock_input (); + } + } + +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; +#endif + + if (f) + { + /* Is this in the tab-bar? */ + if (WINDOWP (f->tab_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tab_bar_p = EQ (window, f->tab_bar_window); + + if (tab_bar_p) + tab_bar_arg = handle_tab_bar_click + (f, x, y, xev->evtype == XI_ButtonPress, + x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } + +#if ! defined (USE_GTK) + /* Is this in the tool-bar? */ + if (WINDOWP (f->tool_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tool_bar_p = EQ (window, f->tool_bar_window); + + if (tool_bar_p && xev->detail < 4) + handle_tool_bar_click + (f, x, y, xev->evtype == XI_ButtonPress, + x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } +#endif /* !USE_GTK */ + + if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + if (! popup_activated ()) +#endif + { + if (ignore_next_mouse_click_timeout) + { + if (xev->evtype == XI_ButtonPress + && xev->time > ignore_next_mouse_click_timeout) + { + ignore_next_mouse_click_timeout = 0; + x_construct_mouse_click (&inev.ie, &bv, f); + } + if (xev->evtype == XI_ButtonRelease) + ignore_next_mouse_click_timeout = 0; + } + else + x_construct_mouse_click (&inev.ie, &bv, f); + + if (!NILP (tab_bar_arg)) + inev.ie.arg = tab_bar_arg; + } + if (FRAME_X_EMBEDDED_P (f)) + xembed_send_message (f, xev->time, + XEMBED_REQUEST_FOCUS, 0, 0, 0); + } + + if (xev->evtype == XI_ButtonPress) + { + dpyinfo->grabbed |= (1 << xev->detail); + device->grab |= (1 << xev->detail); + dpyinfo->last_mouse_frame = f; + if (f && !tab_bar_p) + f->last_tab_bar_item = -1; +#if ! defined (USE_GTK) + if (f && !tool_bar_p) + f->last_tool_bar_item = -1; +#endif /* not USE_GTK */ + + } + else + { + dpyinfo->grabbed &= ~(1 << xev->detail); + device->grab &= ~(1 << xev->detail); + } + + xi_grab_or_ungrab_device (device, dpyinfo, xev->event); + + if (f) + f->mouse_moved = false; + +#if defined (USE_GTK) + /* No Xt toolkit currently available has support for XI2. + So the code here assumes use of GTK. */ + f = x_menubar_window_to_frame (dpyinfo, event); + if (f /* Gtk+ menus only react to the first three buttons. */ + && xev->detail < 3) + { + /* What is done with Core Input ButtonPressed is not + possible here, because GenericEvents cannot be saved. */ + bool was_waiting_for_input = waiting_for_input; + /* This hack was adopted from the NS port. Whether + or not it is actually safe is a different story + altogether. */ + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, true); + waiting_for_input = was_waiting_for_input; + } +#endif + goto XI_OTHER; + } + case XI_KeyPress: + { + int state = xev->mods.effective; + Lisp_Object c; +#ifdef HAVE_XKB + unsigned int mods_rtrn; +#endif + int keycode = xev->detail; + KeySym keysym; + char copy_buffer[81]; + char *copy_bufptr = copy_buffer; + unsigned char *copy_ubufptr; + int copy_bufsiz = sizeof (copy_buffer); + ptrdiff_t i; + int nchars, len; + +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + /* Dispatch XI_KeyPress events when in menu. */ + if (popup_activated ()) + goto XI_OTHER; +#endif + +#ifdef HAVE_X_I18N + XKeyPressedEvent xkey; + + memset (&xkey, 0, sizeof xkey); + + xkey.type = KeyPress; + xkey.serial = xev->serial; + xkey.send_event = xev->send_event; + xkey.display = xev->display; + xkey.window = xev->event; + xkey.root = xev->root; + xkey.subwindow = xev->child; + xkey.time = xev->time; + xkey.state = xev->mods.effective; + xkey.keycode = xev->detail; + xkey.same_screen = True; + + if (x_filter_event (dpyinfo, (XEvent *) &xkey)) + { + *finish = X_EVENT_DROP; + goto XI_OTHER; + } +#endif + +#ifdef HAVE_XKB + if (dpyinfo->xkb_desc) + { + if (!XkbTranslateKeyCode (dpyinfo->xkb_desc, keycode, + state, &mods_rtrn, &keysym)) + goto XI_OTHER; + } + else + { +#endif + int keysyms_per_keycode_return; + KeySym *ksms = XGetKeyboardMapping (dpyinfo->display, keycode, 1, + &keysyms_per_keycode_return); + if (!(keysym = ksms[0])) + { + XFree (ksms); + goto XI_OTHER; + } + XFree (ksms); +#ifdef HAVE_XKB + } +#endif + + if (keysym == NoSymbol) + goto XI_OTHER; + + x_display_set_last_user_time (dpyinfo, xev->time); + ignore_next_mouse_click_timeout = 0; + + f = x_any_window_to_frame (dpyinfo, xev->event); + + /* If mouse-highlight is an integer, input clears out + mouse highlighting. */ + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) + && (f == 0 +#if ! defined (USE_GTK) + || !EQ (f->tool_bar_window, hlinfo->mouse_face_window) +#endif + || !EQ (f->tab_bar_window, hlinfo->mouse_face_window)) + ) + { + clear_mouse_face (hlinfo); + hlinfo->mouse_face_hidden = true; + } + + if (f != 0) + { +#ifdef USE_GTK + /* Don't pass keys to GTK. A Tab will shift focus to the + tool bar in GTK 2.4. Keys will still go to menus and + dialogs because in that case popup_activated is nonzero + (see above). */ + *finish = X_EVENT_DROP; +#endif + /* If not using XIM/XIC, and a compose sequence is in progress, + we break here. Otherwise, chars_matched is always 0. */ + if (compose_status.chars_matched > 0 && nbytes == 0) + goto XI_OTHER; + + memset (&compose_status, 0, sizeof (compose_status)); + + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers + = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), state); + inev.ie.timestamp = xev->time; + +#ifdef HAVE_X_I18N + if (FRAME_XIC (f)) + { + Status status_return; + nbytes = XmbLookupString (FRAME_XIC (f), + &xkey, (char *) copy_bufptr, + copy_bufsiz, &keysym, + &status_return); + + if (status_return == XBufferOverflow) + { + copy_bufsiz = nbytes + 1; + copy_bufptr = alloca (copy_bufsiz); + nbytes = XmbLookupString (FRAME_XIC (f), + &xkey, (char *) copy_bufptr, + copy_bufsiz, &keysym, + &status_return); + } + + if (status_return == XLookupNone) + goto xi_done_keysym; + else if (status_return == XLookupChars) + { + keysym = NoSymbol; + state = 0; + } + else if (status_return != XLookupKeySym + && status_return != XLookupBoth) + emacs_abort (); + } + else +#endif + { +#ifdef HAVE_XKB + int overflow = 0; + KeySym sym = keysym; + + if (dpyinfo->xkb_desc) + { + nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow); + if (overflow) + { + copy_bufptr = alloca ((copy_bufsiz += overflow) + * sizeof *copy_bufptr); + overflow = 0; + nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow); + + if (overflow) + nbytes = 0; + } + } + else +#endif + { + nbytes = XLookupString (&xkey, copy_bufptr, + copy_bufsiz, &keysym, + &compose_status); + } + } + + /* First deal with keysyms which have defined + translations to characters. */ + if (keysym >= 32 && keysym < 128) + /* Avoid explicitly decoding each ASCII character. */ + { + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + + goto xi_done_keysym; + } + + /* Keysyms directly mapped to Unicode characters. */ + if (keysym >= 0x01000000 && keysym <= 0x0110FFFF) + { + if (keysym < 0x01000080) + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + else + inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; + inev.ie.code = keysym & 0xFFFFFF; + goto xi_done_keysym; + } + + /* Now non-ASCII. */ + if (HASH_TABLE_P (Vx_keysym_table) + && (c = Fgethash (make_fixnum (keysym), + Vx_keysym_table, + Qnil), + FIXNATP (c))) + { + inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = XFIXNAT (c); + goto xi_done_keysym; + } + + /* Random non-modifier sorts of keysyms. */ + if (((keysym >= XK_BackSpace && keysym <= XK_Escape) + || keysym == XK_Delete +#ifdef XK_ISO_Left_Tab + || (keysym >= XK_ISO_Left_Tab + && keysym <= XK_ISO_Enter) +#endif + || IsCursorKey (keysym) /* 0xff50 <= x < 0xff60 */ + || IsMiscFunctionKey (keysym) /* 0xff60 <= x < VARIES */ +#ifdef HPUX + /* This recognizes the "extended function + keys". It seems there's no cleaner way. + Test IsModifierKey to avoid handling + mode_switch incorrectly. */ + || (XK_Select <= keysym && keysym < XK_KP_Space) +#endif +#ifdef XK_dead_circumflex + || keysym == XK_dead_circumflex +#endif +#ifdef XK_dead_grave + || keysym == XK_dead_grave +#endif +#ifdef XK_dead_tilde + || keysym == XK_dead_tilde +#endif +#ifdef XK_dead_diaeresis + || keysym == XK_dead_diaeresis +#endif +#ifdef XK_dead_macron + || keysym == XK_dead_macron +#endif +#ifdef XK_dead_degree + || keysym == XK_dead_degree +#endif +#ifdef XK_dead_acute + || keysym == XK_dead_acute +#endif +#ifdef XK_dead_cedilla + || keysym == XK_dead_cedilla +#endif +#ifdef XK_dead_breve + || keysym == XK_dead_breve +#endif +#ifdef XK_dead_ogonek + || keysym == XK_dead_ogonek +#endif +#ifdef XK_dead_caron + || keysym == XK_dead_caron +#endif +#ifdef XK_dead_doubleacute + || keysym == XK_dead_doubleacute +#endif +#ifdef XK_dead_abovedot + || keysym == XK_dead_abovedot +#endif + || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */ + || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */ + /* Any "vendor-specific" key is ok. */ + || (keysym & (1 << 28)) + || (keysym != NoSymbol && nbytes == 0)) + && ! (IsModifierKey (keysym) + /* The symbols from XK_ISO_Lock + to XK_ISO_Last_Group_Lock + don't have real modifiers but + should be treated similarly to + Mode_switch by Emacs. */ +#if defined XK_ISO_Lock && defined XK_ISO_Last_Group_Lock + || (XK_ISO_Lock <= keysym + && keysym <= XK_ISO_Last_Group_Lock) +#endif + )) + { + STORE_KEYSYM_FOR_DEBUG (keysym); + /* make_lispy_event will convert this to a symbolic + key. */ + inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + goto xi_done_keysym; + } + + for (i = 0, nchars = 0; i < nbytes; i++) + { + if (ASCII_CHAR_P (copy_bufptr[i])) + nchars++; + STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]); + } + + if (nchars < nbytes) + { + /* Decode the input data. */ + + setup_coding_system (Vlocale_coding_system, &coding); + coding.src_multibyte = false; + coding.dst_multibyte = true; + /* The input is converted to events, thus we can't + handle composition. Anyway, there's no XIM that + gives us composition information. */ + coding.common_flags &= ~CODING_ANNOTATION_MASK; + + SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH, + nbytes); + coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes; + coding.mode |= CODING_MODE_LAST_BLOCK; + decode_coding_c_string (&coding, (unsigned char *) copy_bufptr, + nbytes, Qnil); + nbytes = coding.produced; + nchars = coding.produced_char; + copy_bufptr = (char *) coding.destination; + } + + copy_ubufptr = (unsigned char *) copy_bufptr; + + /* Convert the input data to a sequence of + character events. */ + for (i = 0; i < nbytes; i += len) + { + int ch; + if (nchars == nbytes) + ch = copy_ubufptr[i], len = 1; + else + ch = string_char_and_length (copy_ubufptr + i, &len); + inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = ch; + kbd_buffer_store_buffered_event (&inev, hold_quit); + } + + inev.ie.kind = NO_EVENT; + goto xi_done_keysym; + } + goto XI_OTHER; + } + case XI_KeyRelease: + x_display_set_last_user_time (dpyinfo, xev->time); +#ifdef HAVE_X_I18N + XKeyPressedEvent xkey; + + memset (&xkey, 0, sizeof xkey); + + xkey.type = KeyRelease; + xkey.serial = xev->serial; + xkey.send_event = xev->send_event; + xkey.display = xev->display; + xkey.window = xev->event; + xkey.root = xev->root; + xkey.subwindow = xev->child; + xkey.time = xev->time; + xkey.state = xev->mods.effective; + xkey.keycode = xev->detail; + xkey.same_screen = True; + + x_filter_event (dpyinfo, (XEvent *) &xkey); +#endif + goto XI_OTHER; + case XI_PropertyEvent: + case XI_HierarchyChanged: + case XI_DeviceChanged: + x_init_master_valuators (dpyinfo); + goto XI_OTHER; + default: + goto XI_OTHER; + } + xi_done_keysym: +#ifdef HAVE_X_I18N + if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) + xic_set_statusarea (f); +#endif + if (must_free_data) + XFreeEventData (dpyinfo->display, &event->xcookie); + goto done_keysym; + XI_OTHER: + if (must_free_data) + XFreeEventData (dpyinfo->display, &event->xcookie); + goto OTHER; + } +#endif default: OTHER: @@ -11723,6 +12942,13 @@ x_lower_frame (struct frame *f) XFlush (FRAME_X_DISPLAY (f)); unblock_input (); } +#ifdef HAVE_XWIDGETS + /* Make sure any X windows owned by xwidget views of the parent + still display below the lowered frame. */ + + if (FRAME_PARENT_FRAME (f)) + lower_frame_xwidget_views (FRAME_PARENT_FRAME (f)); +#endif } static void @@ -13192,6 +14418,40 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->supports_xdbe = true; #endif +#ifdef HAVE_XINPUT2 + dpyinfo->supports_xi2 = false; + int rc; + int major = 2; +#ifdef XI_BarrierHit /* XInput 2.3 */ + int minor = 3; +#elif defined XI_TouchBegin /* XInput 2.2 */ + int minor = 2; +#elif defined XIScrollClass /* XInput 2.1 */ + int minor = 1; +#else /* Some old version of XI2 we're not interested in. */ + int minor = 0; +#endif + int fer, fee; + + if (XQueryExtension (dpyinfo->display, "XInputExtension", + &dpyinfo->xi2_opcode, &fer, &fee)) + { + rc = XIQueryVersion (dpyinfo->display, &major, &minor); + if (rc == Success) + { + dpyinfo->supports_xi2 = true; + x_init_master_valuators (dpyinfo); + } + } + dpyinfo->xi2_version = minor; +#endif + +#ifdef HAVE_XKB + dpyinfo->xkb_desc = XkbGetMap (dpyinfo->display, + XkbAllComponentsMask, + XkbUseCoreKbd); +#endif + #if defined USE_CAIRO || defined HAVE_XFT { /* If we are using Xft, the following precautions should be made: @@ -13624,6 +14884,14 @@ x_delete_terminal (struct terminal *terminal) XrmDestroyDatabase (dpyinfo->rdb); #endif +#ifdef HAVE_XKB + if (dpyinfo->xkb_desc) + XkbFreeKeyboard (dpyinfo->xkb_desc, XkbAllComponentsMask, True); +#endif +#ifdef HAVE_XINPUT2 + if (dpyinfo->supports_xi2) + x_free_xi_devices (dpyinfo); +#endif #ifdef USE_GTK xg_display_close (dpyinfo->display); #else @@ -13783,9 +15051,12 @@ x_initialize (void) void init_xterm (void) { - /* Emacs can handle only core input events, so make sure - Gtk doesn't use Xinput or Xinput2 extensions. */ +#ifndef HAVE_XINPUT2 + /* Emacs can handle only core input events when built without XI2 + support, so make sure Gtk doesn't use Xinput or Xinput2 + extensions. */ xputenv ("GDK_CORE_DEVICE_EVENTS=1"); +#endif } #endif @@ -13842,7 +15113,7 @@ selected window or cursor position is preserved. */); A value of nil means Emacs doesn't use toolkit scroll bars. With the X Window system, the value is a symbol describing the X toolkit. Possible values are: gtk, motif, xaw, or xaw3d. -With MS Windows or Nextstep, the value is t. */); +With MS Windows, Haiku windowing or Nextstep, the value is t. */); #ifdef USE_TOOLKIT_SCROLL_BARS #ifdef USE_MOTIF Vx_toolkit_scroll_bars = intern_c_string ("motif"); @@ -13942,4 +15213,17 @@ gtk_window_move to set or store frame positions and disables some time consuming frame position adjustments. In newer versions of GTK, Emacs always uses gtk_window_move and ignores the value of this variable. */); x_gtk_use_window_move = true; + + DEFVAR_BOOL ("x-coalesce-scroll-events", x_coalesce_scroll_events, + doc: /* Non-nil means send a wheel event only for scrolling at least one screen line. +Otherwise, a wheel event will be sent every time the mouse wheel is +moved. This option is only effective when Emacs is built with XInput +2, with Haiku windowing support, or with NS. */); + x_coalesce_scroll_events = true; + + DEFVAR_LISP ("x-scroll-event-delta-factor", Vx_scroll_event_delta_factor, + doc: /* A scale to apply to pixel deltas reported in scroll events. +This option is only effective when Emacs is built with XInput 2 +support. */); + Vx_scroll_event_delta_factor = make_float (1.0); } diff --git a/src/xterm.h b/src/xterm.h index 9d9534dd629..7abe168bc6f 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -88,6 +88,10 @@ typedef GtkWidget *xt_or_gtk_widget; #include #endif +#ifdef HAVE_XKB +#include +#endif + #include "dispextern.h" #include "termhooks.h" @@ -163,6 +167,28 @@ struct color_name_cache_entry char *name; }; +#ifdef HAVE_XINPUT2 +struct xi_scroll_valuator_t +{ + bool invalid_p; + double current_value; + double emacs_value; + double increment; + + int number; + int horizontal; +}; + +struct xi_device_t +{ + int device_id; + int scroll_valuator_count; + int grab; + + struct xi_scroll_valuator_t *valuators; +}; +#endif + Status x_parse_color (struct frame *f, const char *color_name, XColor *color); @@ -474,6 +500,19 @@ struct x_display_info #ifdef HAVE_XDBE bool supports_xdbe; #endif + +#ifdef HAVE_XINPUT2 + bool supports_xi2; + int xi2_version; + int xi2_opcode; + + int num_devices; + struct xi_device_t *devices; +#endif + +#ifdef HAVE_XKB + XkbDescPtr xkb_desc; +#endif }; #ifdef HAVE_X_I18N @@ -481,6 +520,11 @@ struct x_display_info extern bool use_xim; #endif +#ifdef HAVE_XINPUT2 +/* Defined in xmenu.c. */ +extern int popup_activated_flag; +#endif + /* This is a chain of structures for all the X displays currently in use. */ extern struct x_display_info *x_display_list; diff --git a/src/xwidget.c b/src/xwidget.c index b58fe76a957..d3b7175ef54 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see . */ #include #include "buffer.h" +#include "coding.h" #include "xwidget.h" #include "lisp.h" @@ -31,6 +32,7 @@ along with GNU Emacs. If not, see . */ #include "sysstdio.h" #include "termhooks.h" #include "window.h" +#include "process.h" /* Include xwidget bottom end headers. */ #ifdef USE_GTK @@ -38,10 +40,15 @@ along with GNU Emacs. If not, see . */ #include #include #include +#ifdef HAVE_XINPUT2 +#include +#endif #elif defined NS_IMPL_COCOA #include "nsxwidget.h" #endif +#include + static Lisp_Object id_to_xwidget_map; static Lisp_Object internal_xwidget_view_list; static Lisp_Object internal_xwidget_list; @@ -57,6 +64,7 @@ static gboolean webkit_script_dialog_cb (WebKitWebView *, WebKitScriptDialog *, static void record_osr_embedder (struct xwidget_view *); static void from_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer); static void to_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer); +static GdkWindow *pick_embedded_child (GdkWindow *, double, double, gpointer); #endif static struct xwidget * @@ -76,6 +84,8 @@ allocate_xwidget_view (void) static struct xwidget_view *xwidget_view_lookup (struct xwidget *, struct window *); +static void kill_xwidget (struct xwidget *); + #ifdef USE_GTK static void webkit_view_load_changed_cb (WebKitWebView *, WebKitLoadEvent, @@ -188,16 +198,20 @@ fails. */) || !XWIDGETP (related) || !EQ (XXWIDGET (related)->type, Qwebkit)) { - xw->widget_osr = webkit_web_view_new (); + WebKitWebContext *ctx = webkit_web_context_new (); + xw->widget_osr = webkit_web_view_new_with_context (ctx); + g_object_unref (ctx); + g_signal_connect (G_OBJECT (ctx), + "download-started", + G_CALLBACK (webkit_download_cb), xw); + + webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), + "about:blank"); /* webkitgtk uses GSubprocess which sets sigaction causing Emacs to not catch SIGCHLD with its usual handle setup in 'catch_child_signal'. This resets the SIGCHLD sigaction. */ - struct sigaction old_action; - sigaction (SIGCHLD, NULL, &old_action); - webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), - "about:blank"); - sigaction (SIGCHLD, &old_action, NULL); + catch_child_signal (); } else { @@ -226,13 +240,16 @@ fails. */) gtk_widget_show (xw->widget_osr); gtk_widget_show (xw->widgetwindow_osr); +#ifndef HAVE_XINPUT2 synthesize_focus_in_event (xw->widgetwindow_osr); - +#endif g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), "from-embedder", G_CALLBACK (from_embedder), NULL); g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), "to-embedder", G_CALLBACK (to_embedder), NULL); + g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), + "pick-embedded-child", G_CALLBACK (pick_embedded_child), NULL); /* Store some xwidget data in the gtk widgets for convenient retrieval in the event handlers. */ @@ -246,10 +263,6 @@ fails. */) "load-changed", G_CALLBACK (webkit_view_load_changed_cb), xw); - g_signal_connect (G_OBJECT (webkit_context), - "download-started", - G_CALLBACK (webkit_download_cb), xw); - g_signal_connect (G_OBJECT (xw->widget_osr), "decide-policy", G_CALLBACK @@ -326,6 +339,10 @@ selected frame is not an X-Windows frame. */) GtkContainerClass *klass; GtkWidget *widget; GtkWidget *temp = NULL; +#ifdef HAVE_XINPUT2 + GdkWindow *embedder; + GdkWindow *osw; +#endif #endif CHECK_LIVE_XWIDGET (xwidget); @@ -337,6 +354,16 @@ selected frame is not an X-Windows frame. */) f = SELECTED_FRAME (); #ifdef USE_GTK +#ifdef HAVE_XINPUT2 + /* XI2 GDK devices crash if we try this without an embedder set. */ + if (!f) + return Qnil; + + osw = gtk_widget_get_window (xw->widgetwindow_osr); + embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)); + + gdk_offscreen_window_set_embedder (osw, embedder); +#endif widget = gtk_window_get_focus (GTK_WINDOW (xw->widgetwindow_osr)); if (!widget) @@ -490,6 +517,32 @@ xwidget_from_id (uint32_t id) } #ifdef USE_GTK +static GdkWindow * +pick_embedded_child (GdkWindow *window, double x, double y, + gpointer user_data) +{ + GtkWidget *widget; + GtkWidget *child; + GdkEvent event; + int xout, yout; + + event.any.window = window; + event.any.type = GDK_NOTHING; + + widget = gtk_get_event_widget (&event); + + if (!widget) + return NULL; + + child = find_widget_at_pos (widget, lrint (x), lrint (y), + &xout, &yout); + + if (!child) + return NULL; + + return gtk_widget_get_window (child); +} + static void record_osr_embedder (struct xwidget_view *view) { @@ -795,7 +848,7 @@ run_file_chooser_cb (WebKitWebView *webview, gpointer user_data) { struct frame *f = SELECTED_FRAME (); - GtkWidget *chooser; + GtkFileChooserNative *chooser; GtkFileFilter *filter; bool select_multiple_p; guint response; @@ -810,25 +863,21 @@ run_file_chooser_cb (WebKitWebView *webview, if (!FRAME_WINDOW_P (f)) return TRUE; - chooser = gtk_file_chooser_dialog_new ("Select file", + chooser = gtk_file_chooser_native_new ("Select file", GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), - GTK_FILE_CHOOSER_ACTION_OPEN, - "Cancel", - GTK_RESPONSE_CANCEL, - "Select", - GTK_RESPONSE_ACCEPT, - NULL); + GTK_FILE_CHOOSER_ACTION_OPEN, "Select", + "Cancel"); filter = webkit_file_chooser_request_get_mime_types_filter (request); select_multiple_p = webkit_file_chooser_request_get_select_multiple (request); gtk_file_chooser_set_select_multiple (GTK_FILE_CHOOSER (chooser), select_multiple_p); gtk_file_chooser_add_filter (GTK_FILE_CHOOSER (chooser), filter); - response = gtk_dialog_run (GTK_DIALOG (chooser)); + response = gtk_native_dialog_run (GTK_NATIVE_DIALOG (chooser)); - if (response == GTK_RESPONSE_CANCEL) + if (response != GTK_RESPONSE_ACCEPT) { - gtk_widget_destroy (chooser); + gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser)); webkit_file_chooser_request_cancel (request); return TRUE; @@ -848,7 +897,7 @@ run_file_chooser_cb (WebKitWebView *webview, for (i = 0; i < len; ++i) g_free (files[i]); - gtk_widget_destroy (chooser); + gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser)); return TRUE; } @@ -862,6 +911,12 @@ xwidget_button_1 (struct xwidget_view *view, GdkEvent *xg_event = gdk_event_new (down_p ? GDK_BUTTON_PRESS : GDK_BUTTON_RELEASE); struct xwidget *model = XXWIDGET (view->model); GtkWidget *target; +#ifdef HAVE_XINPUT2 + struct x_display_info *dpyinfo; + struct xi_device_t *xi_device; + GdkSeat *seat; + GdkDevice *device; +#endif /* X and Y should be relative to the origin of view->wdesc. */ x += view->clip_left; @@ -885,6 +940,24 @@ xwidget_button_1 (struct xwidget_view *view, xg_event->button.time = time; xg_event->button.device = find_suitable_pointer (view->frame); +#ifdef HAVE_XINPUT2 + dpyinfo = FRAME_DISPLAY_INFO (view->frame); + device = xg_event->button.device; + + for (int idx = 0; idx < dpyinfo->num_devices; ++idx) + { + xi_device = &dpyinfo->devices[idx]; + + XIUngrabDevice (view->dpy, xi_device->device_id, CurrentTime); + } + + if (device) + { + seat = gdk_device_get_seat (device); + gdk_seat_ungrab (seat); + } +#endif + gtk_main_do_event (xg_event); gdk_event_free (xg_event); } @@ -901,7 +974,12 @@ xwidget_button (struct xwidget_view *view, if (button < 4 || button > 8) xwidget_button_1 (view, down_p, x, y, button, modifier_state, time); +#ifndef HAVE_XINPUT2 else +#else + else if (!FRAME_DISPLAY_INFO (view->frame)->supports_xi2 + || FRAME_DISPLAY_INFO (view->frame)->xi2_version < 1) +#endif { GdkEvent *xg_event = gdk_event_new (GDK_SCROLL); struct xwidget *model = XXWIDGET (view->model); @@ -944,6 +1022,93 @@ xwidget_button (struct xwidget_view *view, } } +#ifdef HAVE_XINPUT2 +void +xwidget_motion_notify (struct xwidget_view *view, + double x, double y, uint state, Time time) +{ + GdkEvent *xg_event; + GtkWidget *target; + struct xwidget *model = XXWIDGET (view->model); + int target_x, target_y; + + if (NILP (model->buffer)) + return; + + record_osr_embedder (view); + + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (x), lrint (y), + &target_x, &target_y); + + if (!target) + { + target_x = lrint (x); + target_y = lrint (y); + target = model->widget_osr; + } + + xg_event = gdk_event_new (GDK_MOTION_NOTIFY); + xg_event->any.window = gtk_widget_get_window (target); + xg_event->motion.x = target_x; + xg_event->motion.y = target_y; + xg_event->motion.x_root = lrint (x); + xg_event->motion.y_root = lrint (y); + xg_event->motion.time = time; + xg_event->motion.state = state; + xg_event->motion.device = find_suitable_pointer (view->frame); + + g_object_ref (xg_event->any.window); + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} + +void +xwidget_scroll (struct xwidget_view *view, double x, double y, + double dx, double dy, uint state, Time time) +{ + GdkEvent *xg_event; + GtkWidget *target; + struct xwidget *model = XXWIDGET (view->model); + int target_x, target_y; + + if (NILP (model->buffer)) + return; + + record_osr_embedder (view); + + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (x), lrint (y), + &target_x, &target_y); + + if (!target) + { + target_x = lrint (x); + target_y = lrint (y); + target = model->widget_osr; + } + + xg_event = gdk_event_new (GDK_SCROLL); + xg_event->any.window = gtk_widget_get_window (target); + xg_event->scroll.direction = GDK_SCROLL_SMOOTH; + xg_event->scroll.x = target_x; + xg_event->scroll.y = target_y; + xg_event->scroll.x_root = lrint (x); + xg_event->scroll.y_root = lrint (y); + xg_event->scroll.time = time; + xg_event->scroll.state = state; + xg_event->scroll.delta_x = dx; + xg_event->scroll.delta_y = dy; + xg_event->scroll.device = find_suitable_pointer (view->frame); + + g_object_ref (xg_event->any.window); + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} +#endif + void xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) { @@ -1016,7 +1181,7 @@ synthesize_focus_in_event (GtkWidget *offscreen_window) wnd = gtk_widget_get_window (offscreen_window); focus_event = gdk_event_new (GDK_FOCUS_CHANGE); - focus_event->any.window = wnd; + focus_event->focus_change.window = wnd; focus_event->focus_change.in = TRUE; if (FRAME_WINDOW_P (SELECTED_FRAME ())) @@ -1067,6 +1232,9 @@ xv_do_draw (struct xwidget_view *xw, struct xwidget *w) GtkOffscreenWindow *wnd; cairo_surface_t *surface; + if (xw->just_resized) + return; + if (NILP (w->buffer)) { XClearWindow (xw->dpy, xw->wdesc); @@ -1176,16 +1344,18 @@ store_xwidget_js_callback_event (struct xwidget *xw, #ifdef USE_GTK static void -store_xwidget_display_event (struct xwidget *xw) +store_xwidget_display_event (struct xwidget *xw, + struct xwidget *src) { struct input_event evt; - Lisp_Object val; + Lisp_Object val, src_val; XSETXWIDGET (val, xw); + XSETXWIDGET (src_val, src); EVENT_INIT (evt); evt.kind = XWIDGET_DISPLAY_EVENT; evt.frame_or_window = Qnil; - evt.arg = val; + evt.arg = list2 (val, src_val); kbd_buffer_store_event (&evt); } @@ -1195,6 +1365,9 @@ webkit_ready_to_show (WebKitWebView *new_view, { Lisp_Object tem; struct xwidget *xw; + struct xwidget *src; + + src = find_xwidget_for_offscreen_window (GDK_WINDOW (user_data)); for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem)) { @@ -1204,14 +1377,21 @@ webkit_ready_to_show (WebKitWebView *new_view, if (EQ (xw->type, Qwebkit) && WEBKIT_WEB_VIEW (xw->widget_osr) == new_view) - store_xwidget_display_event (xw); + { + /* The source widget was destroyed before we had a + chance to display the new widget. */ + if (!src) + kill_xwidget (xw); + else + store_xwidget_display_event (xw, src); + } } } } static GtkWidget * webkit_create_cb_1 (WebKitWebView *webview, - struct xwidget_view *xv) + struct xwidget *xv) { Lisp_Object related; Lisp_Object xwidget; @@ -1229,7 +1409,8 @@ webkit_create_cb_1 (WebKitWebView *webview, widget = XXWIDGET (xwidget)->widget_osr; g_signal_connect (G_OBJECT (widget), "ready-to-show", - G_CALLBACK (webkit_ready_to_show), NULL); + G_CALLBACK (webkit_ready_to_show), + gtk_widget_get_window (xv->widgetwindow_osr)); return widget; } @@ -1451,7 +1632,7 @@ webkit_decide_policy_cb (WebKitWebView *webView, newview = WEBKIT_WEB_VIEW (XXWIDGET (new_xwidget)->widget_osr); webkit_web_view_load_request (newview, request); - store_xwidget_display_event (XXWIDGET (new_xwidget)); + store_xwidget_display_event (XXWIDGET (new_xwidget), xw); return TRUE; } case WEBKIT_POLICY_DECISION_TYPE_NAVIGATION_ACTION: @@ -1583,6 +1764,7 @@ xwidget_init_view (struct xwidget *xww, xv->wdesc = None; xv->frame = s->f; xv->cursor = cursor_for_hit (xww->hit_result, s->f); + xv->just_resized = false; #elif defined NS_IMPL_COCOA nsxwidget_init_view (xv, xww, s, x, y); nsxwidget_resize_view(xv, xww->width, xww->height); @@ -1614,6 +1796,8 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) #ifdef USE_GTK if (!xv) xv = xwidget_init_view (xww, s, x, y); + + xv->just_resized = false; #elif defined NS_IMPL_COCOA if (!xv) { @@ -1636,7 +1820,9 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) } #endif - window_box (s->w, TEXT_AREA, &text_area_x, &text_area_y, + xv->area = s->area; + + window_box (s->w, xv->area, &text_area_x, &text_area_y, &text_area_width, &text_area_height); clip_left = max (0, text_area_x - x); @@ -1686,6 +1872,23 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) clip_bottom - clip_top, 0, CopyFromParent, CopyFromParent, CopyFromParent, CWEventMask, &a); +#ifdef HAVE_XINPUT2 + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + + if (FRAME_DISPLAY_INFO (s->f)->supports_xi2) + { + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_Motion); + XISelectEvents (xv->dpy, xv->wdesc, &mask, 1); + } +#endif + XLowerWindow (xv->dpy, xv->wdesc); XDefineCursor (xv->dpy, xv->wdesc, xv->cursor); xv->cr_surface = cairo_xlib_surface_create (xv->dpy, xv->wdesc, @@ -1776,6 +1979,11 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) } #endif +#ifdef HAVE_XINPUT2 + record_osr_embedder (xv); + synthesize_focus_in_event (xww->widget_osr); +#endif + #ifdef USE_GTK unblock_input (); #endif @@ -1837,6 +2045,7 @@ DEFUN ("xwidget-webkit-goto-uri", uri = ENCODE_FILE (uri); #ifdef USE_GTK webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), SSDATA (uri)); + catch_child_signal (); #elif defined NS_IMPL_COCOA nsxwidget_webkit_goto_uri (xw, SSDATA (uri)); #endif @@ -1972,6 +2181,28 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, xw->width = w; xw->height = h; + block_input (); + + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) + { + if (XWIDGET_VIEW_P (XCAR (tail))) + { + struct xwidget_view *xv = XXWIDGET_VIEW (XCAR (tail)); + if (XXWIDGET (xv->model) == xw) + { +#ifdef USE_GTK + xv->just_resized = true; + SET_FRAME_GARBAGED (xv->frame); +#else + wset_redisplay (XWINDOW (xv->w)); +#endif + } + } + } + + redisplay (); + /* If there is an offscreen widget resize it first. */ #ifdef USE_GTK if (xw->widget_osr) @@ -1986,21 +2217,7 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, #elif defined NS_IMPL_COCOA nsxwidget_resize (xw); #endif - - for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); - tail = XCDR (tail)) - { - if (XWIDGET_VIEW_P (XCAR (tail))) - { - struct xwidget_view *xv = XXWIDGET_VIEW (XCAR (tail)); - if (XXWIDGET (xv->model) == xw) - { - wset_redisplay (XWINDOW (xv->w)); - } - } - } - - redisplay (); + unblock_input (); return Qnil; } @@ -2394,6 +2611,25 @@ using `xwidget-webkit-search'. */) return Qnil; } +DEFUN ("kill-xwidget", Fkill_xwidget, Skill_xwidget, + 1, 1, 0, + doc: /* Kill the specified XWIDGET. +This releases all window system resources associated with XWIDGET, +removes it from `xwidget-list', and detaches it from its buffer. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + + block_input (); + kill_xwidget (xw); + unblock_input (); + + return Qnil; +} + #ifdef USE_GTK DEFUN ("xwidget-webkit-load-html", Fxwidget_webkit_load_html, Sxwidget_webkit_load_html, 2, 3, 0, @@ -2431,8 +2667,181 @@ to "about:blank". */) return Qnil; } + +DEFUN ("xwidget-webkit-back-forward-list", Fxwidget_webkit_back_forward_list, + Sxwidget_webkit_back_forward_list, 1, 2, 0, + doc: /* Return the navigation history of XWIDGET, a WebKit xwidget. + +Return the history as a list of the form (BACK HERE FORWARD), where +HERE is the current navigation item, while BACK and FORWARD are lists +of history items of the form (IDX TITLE URI). Here, IDX is an index +that can be passed to `xwidget-webkit-goto-history', TITLE is a string +containing the human-readable title of the history item, and URI is +the URI of the history item. + +BACK, HERE, and FORWARD can all be nil depending on the state of the +navigation history. + +BACK and FORWARD will each not contain more elements than LIMIT. If +LIMIT is not specified or nil, it is treated as `50'. */) + (Lisp_Object xwidget, Lisp_Object limit) +{ + struct xwidget *xw; + Lisp_Object back, here, forward; + WebKitWebView *webview; + WebKitBackForwardList *list; + WebKitBackForwardListItem *item; + GList *parent, *tem; + int i; + unsigned int lim; + Lisp_Object title, uri; + const gchar *item_title, *item_uri; + + back = Qnil; + here = Qnil; + forward = Qnil; + + if (NILP (limit)) + limit = make_fixnum (50); + else + CHECK_FIXNAT (limit); + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + list = webkit_web_view_get_back_forward_list (webview); + item = webkit_back_forward_list_get_current_item (list); + lim = XFIXNAT (limit); + + if (item) + { + item_title = webkit_back_forward_list_item_get_title (item); + item_uri = webkit_back_forward_list_item_get_uri (item); + here = list3 (make_fixnum (0), + build_string_from_utf8 (item_title ? item_title : ""), + build_string_from_utf8 (item_uri ? item_uri : "")); + } + parent = webkit_back_forward_list_get_back_list_with_limit (list, lim); + + if (parent) + { + for (i = 1, tem = parent; tem; tem = tem->next, ++i) + { + item = tem->data; + item_title = webkit_back_forward_list_item_get_title (item); + item_uri = webkit_back_forward_list_item_get_uri (item); + title = build_string_from_utf8 (item_title ? item_title : ""); + uri = build_string_from_utf8 (item_uri ? item_uri : ""); + back = Fcons (list3 (make_fixnum (-i), title, uri), back); + } + } + + back = Fnreverse (back); + g_list_free (parent); + + parent = webkit_back_forward_list_get_forward_list_with_limit (list, lim); + + if (parent) + { + for (i = 1, tem = parent; tem; tem = tem->next, ++i) + { + item = tem->data; + item_title = webkit_back_forward_list_item_get_title (item); + item_uri = webkit_back_forward_list_item_get_uri (item); + title = build_string_from_utf8 (item_title ? item_title : ""); + uri = build_string_from_utf8 (item_uri ? item_uri : ""); + forward = Fcons (list3 (make_fixnum (i), title, uri), forward); + } + } + + forward = Fnreverse (forward); + g_list_free (parent); + + return list3 (back, here, forward); +} + +DEFUN ("xwidget-webkit-estimated-load-progress", + Fxwidget_webkit_estimated_load_progress, Sxwidget_webkit_estimated_load_progress, + 1, 1, 0, doc: /* Get the estimated load progress of XWIDGET, a WebKit widget. +Return a value ranging from 0.0 to 1.0, based on how close XWIDGET +is to completely loading its page. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; + WebKitWebView *webview; + double value; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + value = webkit_web_view_get_estimated_load_progress (webview); + unblock_input (); + + return make_float (value); +} #endif +DEFUN ("xwidget-webkit-set-cookie-storage-file", + Fxwidget_webkit_set_cookie_storage_file, Sxwidget_webkit_set_cookie_storage_file, + 2, 2, 0, doc: /* Make the WebKit widget XWIDGET load and store cookies in FILE. + +Cookies will be stored as plain text in FILE, which must be an +absolute file name. All xwidgets related to XWIDGET will also +store cookies in FILE and load them from there. */) + (Lisp_Object xwidget, Lisp_Object file) +{ +#ifdef USE_GTK + struct xwidget *xw; + WebKitWebView *webview; + WebKitWebContext *context; + WebKitCookieManager *manager; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + CHECK_STRING (file); + + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + context = webkit_web_view_get_context (webview); + manager = webkit_web_context_get_cookie_manager (context); + webkit_cookie_manager_set_persistent_storage (manager, + SSDATA (ENCODE_UTF_8 (file)), + WEBKIT_COOKIE_PERSISTENT_STORAGE_TEXT); + unblock_input (); +#endif + + return Qnil; +} + +DEFUN ("xwidget-webkit-stop-loading", Fxwidget_webkit_stop_loading, + Sxwidget_webkit_stop_loading, + 1, 1, 0, doc: /* Stop loading data in the WebKit widget XWIDGET. +This will stop any data transfer that may still be in progress inside +XWIDGET as part of loading a page. */) + (Lisp_Object xwidget) +{ +#ifdef USE_GTK + struct xwidget *xw; + WebKitWebView *webview; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + webkit_web_view_stop_loading (webview); + unblock_input (); +#endif + + return Qnil; +} + void syms_of_xwidget (void) { @@ -2473,9 +2882,14 @@ syms_of_xwidget (void) defsubr (&Sxwidget_webkit_next_result); defsubr (&Sxwidget_webkit_previous_result); defsubr (&Sset_xwidget_buffer); + defsubr (&Sxwidget_webkit_set_cookie_storage_file); + defsubr (&Sxwidget_webkit_stop_loading); #ifdef USE_GTK defsubr (&Sxwidget_webkit_load_html); + defsubr (&Sxwidget_webkit_back_forward_list); + defsubr (&Sxwidget_webkit_estimated_load_progress); #endif + defsubr (&Skill_xwidget); DEFSYM (QCxwidget, ":xwidget"); DEFSYM (QCtitle, ":title"); @@ -2489,11 +2903,11 @@ syms_of_xwidget (void) DEFSYM (QCplist, ":plist"); DEFVAR_LISP ("xwidget-list", Vxwidget_list, - doc: /* xwidgets list. */); + doc: /* List of all xwidgets that have not been killed. */); Vxwidget_list = Qnil; DEFVAR_LISP ("xwidget-view-list", Vxwidget_view_list, - doc: /* xwidget views list. */); + doc: /* List of all xwidget views. */); Vxwidget_view_list = Qnil; Fprovide (intern ("xwidget-internal"), Qnil); @@ -2651,19 +3065,16 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) xwidget_end_redisplay (w->current_matrix); */ struct xwidget_view *xv = xwidget_view_lookup (xwidget_from_id (glyph->u.xwidget), w); -#ifdef USE_GTK - /* FIXME: Is it safe to assume xwidget_view_lookup - always succeeds here? If so, this comment can be removed. - If not, the code probably needs fixing. */ - eassume (xv); - xwidget_touch (xv); -#elif defined NS_IMPL_COCOA - /* In NS xwidget, xv can be NULL for the second or + + /* In NS xwidget, xv can be NULL for the second or later views for a model, the result of 1 to 1 - model view relation enforcement. */ + model view relation enforcement. `xwidget_view_lookup' + has also been observed to return NULL here on X-Windows + at least once, so stay safe and only touch it if it's + not NULL. */ + if (xv) xwidget_touch (xv); -#endif } } } @@ -2701,6 +3112,20 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) } #ifdef USE_GTK +void +lower_frame_xwidget_views (struct frame *f) +{ + struct xwidget_view *xv; + + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) + { + xv = XXWIDGET_VIEW (XCAR (tail)); + if (xv->frame == f && xv->wdesc != None) + XLowerWindow (xv->dpy, xv->wdesc); + } +} + void kill_frame_xwidget_views (struct frame *f) { @@ -2719,6 +3144,45 @@ kill_frame_xwidget_views (struct frame *f) } #endif +static void +kill_xwidget (struct xwidget *xw) +{ + Lisp_Object val; + XSETXWIDGET (val, xw); + + internal_xwidget_list = Fdelq (val, internal_xwidget_list); + Vxwidget_list = Fcopy_sequence (internal_xwidget_list); +#ifdef USE_GTK + xw->buffer = Qnil; + + if (xw->widget_osr && xw->widgetwindow_osr) + { + gtk_widget_destroy (xw->widget_osr); + gtk_widget_destroy (xw->widgetwindow_osr); + } + + if (xw->find_text) + xfree (xw->find_text); + + if (!NILP (xw->script_callbacks)) + { + for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++) + { + Lisp_Object cb = AREF (xw->script_callbacks, idx); + if (!NILP (cb)) + xfree (xmint_pointer (XCAR (cb))); + ASET (xw->script_callbacks, idx, Qnil); + } + } + + xw->widget_osr = NULL; + xw->widgetwindow_osr = NULL; + xw->find_text = NULL; +#elif defined NS_IMPL_COCOA + nsxwidget_kill (xw); +#endif +} + /* Kill all xwidget in BUFFER. */ void kill_buffer_xwidgets (Lisp_Object buffer) @@ -2727,36 +3191,11 @@ kill_buffer_xwidgets (Lisp_Object buffer) for (tail = Fget_buffer_xwidgets (buffer); CONSP (tail); tail = XCDR (tail)) { xwidget = XCAR (tail); - internal_xwidget_list = Fdelq (xwidget, internal_xwidget_list); - Vxwidget_list = Fcopy_sequence (internal_xwidget_list); { CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); - xw->buffer = Qnil; -#ifdef USE_GTK - if (xw->widget_osr && xw->widgetwindow_osr) - { - gtk_widget_destroy (xw->widget_osr); - gtk_widget_destroy (xw->widgetwindow_osr); - } - if (xw->find_text) - xfree (xw->find_text); - if (!NILP (xw->script_callbacks)) - for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++) - { - Lisp_Object cb = AREF (xw->script_callbacks, idx); - if (!NILP (cb)) - xfree (xmint_pointer (XCAR (cb))); - ASET (xw->script_callbacks, idx, Qnil); - } - - xw->widget_osr = NULL; - xw->widgetwindow_osr = NULL; - xw->find_text = NULL; -#elif defined NS_IMPL_COCOA - nsxwidget_kill (xw); -#endif + kill_xwidget (xw); } } } diff --git a/src/xwidget.h b/src/xwidget.h index 4377b50e840..f2d497c0920 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -104,6 +104,8 @@ struct xwidget_view /* The "live" instance isn't drawn. */ bool hidden; + enum glyph_row_area area; + #if defined (USE_GTK) Display *dpy; Window wdesc; @@ -112,6 +114,7 @@ struct xwidget_view cairo_surface_t *cr_surface; cairo_t *cr_context; + int just_resized; #elif defined (NS_IMPL_COCOA) # ifdef __OBJC__ XvWindow *xvWindow; @@ -186,11 +189,18 @@ extern struct xwidget *xwidget_from_id (uint32_t id); #ifdef HAVE_X_WINDOWS struct xwidget_view *xwidget_view_from_window (Window wdesc); void xwidget_expose (struct xwidget_view *xv); +extern void lower_frame_xwidget_views (struct frame *f); extern void kill_frame_xwidget_views (struct frame *f); extern void xwidget_button (struct xwidget_view *, bool, int, int, int, int, Time); extern void xwidget_motion_or_crossing (struct xwidget_view *, const XEvent *); +#ifdef HAVE_XINPUT2 +extern void xwidget_motion_notify (struct xwidget_view *, double, + double, uint, Time); +extern void xwidget_scroll (struct xwidget_view *, double, double, + double, double, uint, Time); +#endif #endif #else INLINE_HEADER_BEGIN diff --git a/test/Makefile.in b/test/Makefile.in index 7bef1c36605..51696d7faaf 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -31,7 +31,7 @@ SHELL = @SHELL@ srcdir = @srcdir@ -abs_top_srcdir=@abs_top_srcdir@ +abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ VPATH = $(srcdir) @@ -67,7 +67,7 @@ elpa_opts = $(foreach el,$(elpa_els),$(and $(wildcard $(el)),-L $(dir $(el)) -l # directory, we can use emacs --chdir. EMACS = ../src/emacs -EMACS_EXTRAOPT= +EMACS_EXTRAOPT = # Command line flags for Emacs. # Apparently MSYS bash would convert "-L :" to "-L ;" anyway, @@ -252,9 +252,12 @@ endef $(foreach test,${TESTS},$(eval $(call test_template,${test}))) ## Get the tests for only a specific directory. -SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d ! -path "*resources*" -print)) +SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d \ + ! \( -path "*resources*" -o -path "*auto-save-list" \) -print)) +SUBDIR_TARGETS = define subdir_template + SUBDIR_TARGETS += check-$(subst /,-,$(1)) .PHONY: check-$(subst /,-,$(1)) check-$(subst /,-,$(1)): @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \ @@ -367,3 +370,14 @@ maintainer-clean: distclean bootstrap-clean check-declare: $(emacs) -l check-declare \ --eval '(check-declare-directory "$(srcdir)")' + +.PHONY: subdirs subdir-targets generate-test-jobs + +subdirs: + @echo $(SUBDIRS) + +subdir-targets: + @echo $(SUBDIR_TARGETS) + +generate-test-jobs: + @$(MAKE) -C infra generate-test-jobs SUBDIRS="$(SUBDIRS)" diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in new file mode 100644 index 00000000000..fd11d367983 --- /dev/null +++ b/test/infra/Makefile.in @@ -0,0 +1,102 @@ +### @configure_input@ + +# Copyright (C) 2021 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see . + +### Commentary: + +## Generate the test-jobs.yml file for emba. + +### Code: + +SHELL = @SHELL@ + +top_builddir = @top_builddir@ + +-include ${top_builddir}/src/verbose.mk + +## Get the tests for only a specific directory. +SUBDIRS ?= $(shell make -s -C .. subdirs) +SUBDIR_TARGETS = +FILE = test-jobs.yml +tn = $$$${test_name} +cps = $$$$CI_PIPELINE_SOURCE + +define subdir_template + $(eval target = check-$(subst /,-,$(1))) + SUBDIR_TARGETS += $(target) + + $(eval + ifeq ($(findstring src, $(1)), src) + define changes + @echo ' - $(1)/*.{h,c}' >>$(FILE) + endef + else ifeq ($(findstring eieio, $(1)), eieio) + define changes + @echo ' - lisp/emacs-lisp/eieio*.el' >>$(FILE) + endef + else ifeq ($(findstring faceup, $(1)), faceup) + define changes + @echo ' - lisp/emacs-lisp/faceup*.el' >>$(FILE) + endef + else ifeq ($(findstring so-long, $(1)), so-long) + define changes + @echo ' - lisp/so-long*.el' >>$(FILE) + endef + else ifeq ($(findstring misc, $(1)), misc) + define changes + @echo ' - admin/*.el' >>$(FILE) + endef + else + define changes + @echo ' - $(1)/*.el' >>$(FILE) + endef + endif) + + $(target): + @echo >>$(FILE) + @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE) + @echo ' stage: normal' >>$(FILE) + @echo ' extends: [.job-template, .test-template]' >>$(FILE) + @echo ' needs:' >>$(FILE) + @echo ' - job: build-image-inotify' >>$(FILE) + @echo ' optional: true' >>$(FILE) + @echo ' rules:' >>$(FILE) + @echo " - if: '"'${cps} == "schedule"'"'" >>$(FILE) + @echo ' when: never' >>$(FILE) + @echo ' - changes:' >>$(FILE) + $(changes) + @echo ' - test/$(1)/*.el' >>$(FILE) + @echo ' - test/$(1)/*resources/**' >>$(FILE) + @echo ' variables:' >>$(FILE) + @echo ' target: emacs-inotify' >>$(FILE) + @echo ' make_params: "-C test $(target)"' >>$(FILE) +endef + +$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) + +all: generate-test-jobs + +.PHONY: generate-test-jobs $(FILE) $(SUBDIR_TARGETS) + +generate-test-jobs: clean $(FILE) $(SUBDIR_TARGETS) + +$(FILE): + $(AM_V_GEN) + +clean: + @rm -f $(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 001c7795725..4b97f5f0a84 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -15,7 +15,7 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see . -# GNU Emacs support for the GitLab protocol for CI +# GNU Emacs support for the GitLab protocol for CI. # The presence of this file does not imply any FSF/GNU endorsement of # any particular service that uses that protocol. Also, it is intended for @@ -44,10 +44,9 @@ workflow: variables: GIT_STRATEGY: fetch EMACS_EMBA_CI: 1 - # Three hours, see below. - EMACS_TEST_TIMEOUT: 10800 + EMACS_TEST_TIMEOUT: 3600 EMACS_TEST_VERBOSE: 1 - # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled + # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled # DOCKER_HOST: tcp://docker:2376 # DOCKER_TLS_CERTDIR: "/certs" # Put the configuration for each run in a separate directory to @@ -57,6 +56,8 @@ variables: # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap # across multiple builds. BUILD_TAG: ${CI_COMMIT_REF_SLUG} + # Disable if you don't need it, it can be a security risk. + # CI_DEBUG_TRACE: "true" default: image: docker:19.03.12 @@ -69,32 +70,6 @@ default: .job-template: variables: test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} - rules: - - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**.el - - src/*.{h,c} - - test/infra/* - - test/lib-src/*.el - - test/lisp/**.el - - test/misc/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never # These will be cached across builds. cache: key: ${CI_COMMIT_SHA} @@ -115,9 +90,11 @@ default: # - 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 rm ${test_name} - # - ls -alR ${test_name} + - /usr/bin/find ${test_name} ! -name "*.log" -type f -delete + - /usr/bin/find ${test_name} -empty -type d -delete .build-template: needs: [] @@ -125,15 +102,17 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' when: always - changes: - - "**Makefile.in" - - .gitlab-ci.yml + - "**.in" + - "**.yml" + - GNUmakefile - aclocal.m4 - autogen.sh - configure.ac - lib/*.{h,c} + - lib/malloc/*.{h,c} - lisp/emacs-lisp/*.el - src/*.{h,c} - - test/infra/* + - test/infra/Dockerfile.emba - changes: # gfilemonitor, kqueue - src/gfilenotify.c @@ -150,19 +129,12 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: - # Do not run fast and normal test jobs when scheduled. - rules: - - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' - when: never - - when: always artifacts: name: ${test_name} public: true expire_in: 1 week paths: - - ${test_name}/**/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/ when: always .gnustep-template: @@ -170,27 +142,26 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**Makefile.in" - - .gitlab-ci.yml - - configure.ac + - "**.in" + - "**.yml" - src/ns*.{h,m} - src/macfont.{h,m} - lisp/term/ns-win.el - nextstep/** - - test/infra/* + - test/infra/Dockerfile.emba .filenotify-gio-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**Makefile.in" - - .gitlab-ci.yml + - "**.in" + - "**.yml" - lisp/autorevert.el - lisp/filenotify.el - lisp/net/tramp-sh.el - src/gfilenotify.c - - test/infra/* + - test/infra/Dockerfile.emba - test/lisp/autorevert-tests.el - test/lisp/filenotify-tests.el @@ -199,54 +170,46 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**Makefile.in" - - .gitlab-ci.yml + - "**.in" + - "**.yml" - lisp/emacs-lisp/comp.el - lisp/emacs-lisp/comp-cstr.el - src/comp.{h,m} - - test/infra/* + - test/infra/Dockerfile.emba - test/src/comp-resources/*.el - test/src/comp-tests.el timeout: 8 hours stages: - build-images -# - fast - normal - platform-images - platforms - native-comp-images - native-comp - - slow build-image-inotify: stage: build-images extends: [.job-template, .build-template] variables: target: emacs-inotify -# Temporarily. - timeout: 8 hours -# test-fast-inotify: -# stage: fast -# extends: [.job-template, .test-template] -# variables: -# target: emacs-inotify -# make_params: "-C test check" +include: '/test/infra/test-jobs.yml' -test-lisp-inotify: +test-all-inotify: + # This tests also file monitor libraries inotify and inotifywatch. stage: normal extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + # Note there's no "changes" section, so this always runs on a schedule. + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' variables: target: emacs-inotify - make_params: "-C test check-lisp" - -test-lisp-net-inotify: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp-net" + make_params: check-expensive build-image-filenotify-gio: stage: platform-images @@ -254,26 +217,30 @@ build-image-filenotify-gio: variables: target: emacs-filenotify-gio +test-filenotify-gio: + # This tests file monitor libraries gfilemonitor and gio. + stage: platforms + extends: [.job-template, .test-template, .filenotify-gio-template] + needs: + - job: build-image-filenotify-gio + optional: true + variables: + target: emacs-filenotify-gio + make_params: "-k -C test autorevert-tests.log filenotify-tests.log" + build-image-gnustep: stage: platform-images extends: [.job-template, .build-template, .gnustep-template] variables: target: emacs-gnustep -test-filenotify-gio: - # This tests file monitor libraries gfilemonitor and gio. - stage: platforms - needs: [build-image-filenotify-gio] - extends: [.job-template, .test-template, .filenotify-gio-template] - variables: - target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests.log filenotify-tests.log" - test-gnustep: # This tests the GNUstep build process. stage: platforms - needs: [build-image-gnustep] extends: [.job-template, .gnustep-template] + needs: + - job: build-image-gnustep + optional: true variables: target: emacs-gnustep make_params: install @@ -298,28 +265,13 @@ build-native-comp-speed2: test-native-comp-speed0: stage: native-comp - needs: [build-native-comp-speed0] extends: [.job-template, .test-template, .native-comp-template] + needs: + - job: build-native-comp-speed0 + optional: true variables: target: emacs-native-comp-speed0 - make_params: >- - -C test check EXCLUDE_TESTS=%emacs-module-tests.el - SELECTOR='(not (tag :unstable))' - -test-all-inotify: - # This tests also file monitor libraries inotify and inotifywatch. - stage: slow - needs: [build-image-inotify] - extends: [.job-template, .test-template] - rules: - # Note there's no "changes" section, so this always runs on a schedule. - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - variables: - target: emacs-inotify - make_params: check-expensive EXCLUDE_TESTS=%emacs-module-tests.el - # Two hours. - EMACS_TEST_TIMEOUT: 7200 + make_params: "-C test 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 new file mode 100644 index 00000000000..bad8575b5c5 --- /dev/null +++ b/test/infra/test-jobs.yml @@ -0,0 +1,544 @@ + +test-lib-src-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lib-src/*.{h,c} + - test/lib-src/*.el + - test/lib-src/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lib-src" + +test-lisp-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/*.el + - test/lisp/*.el + - test/lisp/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp" + +test-lisp-calc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/calc/*.el + - test/lisp/calc/*.el + - test/lisp/calc/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-calc" + +test-lisp-calendar-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/calendar/*.el + - test/lisp/calendar/*.el + - test/lisp/calendar/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-calendar" + +test-lisp-cedet-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/*.el + - test/lisp/cedet/*.el + - test/lisp/cedet/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-cedet" + +test-lisp-cedet-semantic-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/semantic/*.el + - test/lisp/cedet/semantic/*.el + - test/lisp/cedet/semantic/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-cedet-semantic" + +test-lisp-cedet-semantic-bovine-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/semantic/bovine/*.el + - test/lisp/cedet/semantic/bovine/*.el + - test/lisp/cedet/semantic/bovine/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-cedet-semantic-bovine" + +test-lisp-cedet-srecode-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/srecode/*.el + - test/lisp/cedet/srecode/*.el + - test/lisp/cedet/srecode/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-cedet-srecode" + +test-lisp-emacs-lisp-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emacs-lisp/*.el + - test/lisp/emacs-lisp/*.el + - test/lisp/emacs-lisp/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-emacs-lisp" + +test-lisp-emacs-lisp-eieio-tests-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emacs-lisp/eieio*.el + - test/lisp/emacs-lisp/eieio-tests/*.el + - test/lisp/emacs-lisp/eieio-tests/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-emacs-lisp-eieio-tests" + +test-lisp-emacs-lisp-faceup-tests-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emacs-lisp/faceup*.el + - test/lisp/emacs-lisp/faceup-tests/*.el + - test/lisp/emacs-lisp/faceup-tests/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-emacs-lisp-faceup-tests" + +test-lisp-emulation-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emulation/*.el + - test/lisp/emulation/*.el + - test/lisp/emulation/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-emulation" + +test-lisp-erc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/erc/*.el + - test/lisp/erc/*.el + - test/lisp/erc/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-erc" + +test-lisp-eshell-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/eshell/*.el + - test/lisp/eshell/*.el + - test/lisp/eshell/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-eshell" + +test-lisp-gnus-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/gnus/*.el + - test/lisp/gnus/*.el + - test/lisp/gnus/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-gnus" + +test-lisp-image-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/image/*.el + - test/lisp/image/*.el + - test/lisp/image/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-image" + +test-lisp-international-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/international/*.el + - test/lisp/international/*.el + - test/lisp/international/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-international" + +test-lisp-mail-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/mail/*.el + - test/lisp/mail/*.el + - test/lisp/mail/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-mail" + +test-lisp-mh-e-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/mh-e/*.el + - test/lisp/mh-e/*.el + - test/lisp/mh-e/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-mh-e" + +test-lisp-net-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/net/*.el + - test/lisp/net/*.el + - test/lisp/net/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-net" + +test-lisp-nxml-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/nxml/*.el + - test/lisp/nxml/*.el + - test/lisp/nxml/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-nxml" + +test-lisp-obsolete-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/obsolete/*.el + - test/lisp/obsolete/*.el + - test/lisp/obsolete/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-obsolete" + +test-lisp-org-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/org/*.el + - test/lisp/org/*.el + - test/lisp/org/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-org" + +test-lisp-play-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/play/*.el + - test/lisp/play/*.el + - test/lisp/play/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-play" + +test-lisp-progmodes-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/progmodes/*.el + - test/lisp/progmodes/*.el + - test/lisp/progmodes/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-progmodes" + +test-lisp-so-long-tests-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/so-long*.el + - test/lisp/so-long-tests/*.el + - test/lisp/so-long-tests/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-so-long-tests" + +test-lisp-term-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/term/*.el + - test/lisp/term/*.el + - test/lisp/term/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-term" + +test-lisp-textmodes-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/textmodes/*.el + - test/lisp/textmodes/*.el + - test/lisp/textmodes/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-textmodes" + +test-lisp-url-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/url/*.el + - test/lisp/url/*.el + - test/lisp/url/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-url" + +test-lisp-vc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/vc/*.el + - test/lisp/vc/*.el + - test/lisp/vc/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-lisp-vc" + +test-misc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - admin/*.el + - test/misc/*.el + - test/misc/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-misc" + +test-src-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - src/*.{h,c} + - test/src/*.el + - test/src/*resources/** + variables: + target: emacs-inotify + make_params: "-C test check-src" diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 9e8a8e7b479..1551922028c 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -1633,28 +1633,32 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (let ((time (icalendar--decode-isodatetime string day zone))) (format-time-string "%FT%T%z" (encode-time time) 0))) -(defun icalendar-tests--decode-isodatetime (_ical-string) +(ert-deftest icalendar-tests--decode-isodatetime () "Test `icalendar--decode-isodatetime'." - (should (equal (icalendar-test--format "20040917T050910-0200") - "2004-09-17T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910") + (should (equal (icalendar-test--format "20040917T050910-02:00") "2004-09-17T03:09:10+0000")) + (let ((orig (icalendar-test--format "20040917T050910"))) + (unwind-protect + (progn + (set-time-zone-rule "UTC-02:00") + (should (equal (icalendar-test--format "20040917T050910") + "2004-09-17T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T0509") + "2004-09-17T03:09:00+0000")) + (should (equal (icalendar-test--format "20040917") + "2004-09-16T22:00:00+0000")) + (should (equal (icalendar-test--format "20040917T050910" 1) + "2004-09-18T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910" 30) + "2004-10-17T03:09:10+0000"))) + (set-time-zone-rule 'wall) ;; (set-time-zone-rule nil) is broken + (should (equal orig (icalendar-test--format "20040917T050910"))))) (should (equal (icalendar-test--format "20040917T050910Z") "2004-09-17T05:09:10+0000")) - (should (equal (icalendar-test--format "20040917T0509") - "2004-09-17T03:09:00+0000")) - (should (equal (icalendar-test--format "20040917") - "2004-09-16T22:00:00+0000")) - (should (equal (icalendar-test--format "20040917T050910" 1) - "2004-09-18T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910" 30) - "2004-10-17T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910" -1) - "2004-09-16T03:09:10+0000")) - + (should (equal (icalendar-test--format "20040917T050910" -1 0) + "2004-09-16T05:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910" nil -3600) "2004-09-17T06:09:10+0000"))) - (provide 'icalendar-tests) ;;; icalendar-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 1e32dbfb609..85727bd0916 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -97,8 +97,8 @@ (with-temp-buffer (cl-progv ;; FIXME: avoid `eval' - (mapcar #'car (eval bindings)) - (mapcar #'cdr (eval bindings)) + (mapcar #'car (eval bindings t)) + (mapcar #'cdr (eval bindings t)) (dlet ((python-indent-guess-indent-offset-verbose nil)) (funcall mode) (insert fixture) @@ -187,7 +187,7 @@ The buffer's contents should %s: (fixture-fn '#'electric-pair-mode)) `(progn ,@(cl-loop - for mode in (eval modes) ;FIXME: avoid `eval' + for mode in (eval modes t) ;FIXME: avoid `eval' append (cl-loop for (prefix suffix extra-desc) in @@ -550,16 +550,6 @@ baz\"\"" (electric-indent-mode 1) (electric-layout-mode 1))) -(define-electric-pair-test js-mode-braces-with-layout-and-indent - "" "{" :expected-string "{\n \n}" :expected-point 7 - :modes '(js-mode) - :test-in-comments nil - :test-in-strings nil - :fixture-fn (lambda () - (electric-pair-mode 1) - (electric-indent-mode 1) - (electric-layout-mode 1))) - ;;; Backspacing ;;; TODO: better tests diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 5c4e5305ecc..e35a7a729bc 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -49,7 +49,7 @@ (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) (backtrace-print)))) - (eval backtrace-tests--uncompiled-functions)) + (eval backtrace-tests--uncompiled-functions t)) (defun backtrace-tests--backtrace-lines () (if debugger-stack-frame-as-list diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el new file mode 100644 index 00000000000..37cfe463bfe --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el @@ -0,0 +1,17 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "None of this should be considered too wide. + +; this should be treated as 60 characters - no warning +\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window] + +; 64 * 'x' does not warn +\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x' + +; keymaps are just ignored +\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + +\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map} + +bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar +") diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index dbc0aa3db42..816f14a18d5 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -955,6 +955,10 @@ byte-compiled. Run with dynamic binding." "warn-wide-docstring-ignore-override.el" "defvar .foo-bar. docstring wider than .* characters" 'reverse) +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-substitutions.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + (bytecomp--define-warning-file-test "warn-wide-docstring-ignore.el" "defvar .foo-bar. docstring wider than .* characters" 'reverse) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index a132d736383..854e371b32f 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -353,13 +353,6 @@ (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) (should-error (cl-fifth "12345") :type 'wrong-type-argument)) -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - (ert-deftest cl-lib-test-sixth () (should (null (cl-sixth '()))) (should (null (cl-sixth '(1 2 3 4 5)))) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 033764a7f98..be2c0fa02b4 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -529,7 +529,7 @@ collection clause." (should-error ;; Use `eval' so the error is signaled when running the test rather than ;; when macroexpanding it. - (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))))) + (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t)) ;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to ;; see its `gv-expander'. (should (equal (let ((l '(0))) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 79576d24032..1a8c9bf4f08 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -39,10 +39,11 @@ (defun ert-self-test () "Run ERT's self-tests and make sure they actually ran." (let ((window-configuration (current-window-configuration))) - (let ((ert--test-body-was-run nil)) + (let ((ert--test-body-was-run nil) + (ert--output-buffer-name " *ert self-tests*")) ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. - (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (let ((stats (ert-run-tests-interactively "^ert-"))) (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. @@ -519,17 +520,18 @@ This macro is used to test if macroexpansion in `should' works." :body (lambda () (ert-skip "skip message"))))) (let ((ert-debug-on-error nil)) - (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((buffer-name (generate-new-buffer-name + " *ert-test-run-tests*")) + (ert--output-buffer-name buffer-name) + (messages nil) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test, skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test, skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " @@ -551,6 +553,68 @@ This macro is used to test if macroexpansion in `should' works." (when (get-buffer buffer-name) (kill-buffer buffer-name)))))))) +(ert-deftest ert-test-run-tests-batch () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (long-list (make-list 11 1)) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1))))) + (failing-test-2 + (make-ert-test :name 'failing-test-2 + :body (lambda () (should (equal long-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-print-level 10) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1 ,failing-test-2)))))) + (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$") + (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$") + found-long + found-complex) + (cl-loop for msg in (reverse messages) + do + (unless found-long + (setq found-long (string-match long-text msg))) + (unless found-complex + (setq found-complex (string-match complex-text msg)))) + (should found-long) + (should found-complex))))) + +(ert-deftest ert-test-run-tests-batch-expensive () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-backtrace-line-length nil) + (ert-batch-print-level 6) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1)))))) + (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))") + found-frame) + (cl-loop for msg in (reverse messages) + do + (unless found-frame + (setq found-frame (cl-search frame msg :test 'equal)))) + (should found-frame))))) + (ert-deftest ert-test-special-operator-p () (should (ert--special-operator-p 'if)) (should-not (ert--special-operator-p 'car)) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 9baa9941586..7106b7abc0c 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -103,23 +103,27 @@ (ert-deftest ert-test-run-tests-interactively-2 () :tags '(:causes-redisplay) - (let* ((passing-test (make-ert-test :name 'passing-test - :body (lambda () (ert-pass)))) - (failing-test (make-ert-test :name 'failing-test - :body (lambda () - (ert-info ((propertize "foo\nbar" - 'a 'b)) - (ert-fail - "failure message"))))) - (skipped-test (make-ert-test :name 'skipped-test - :body (lambda () (ert-skip - "skip message")))) - (ert-debug-on-error nil) - (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((passing-test (make-ert-test + :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test + :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test + :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (messages nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages))) + (ert--output-buffer-name buffer-name)) (cl-flet ((expected-string (with-font-lock-p) (ert-propertized-string "Selector: (member " @@ -152,14 +156,12 @@ "failing-test" nil "\n Info: " '(a b) "foo\n" nil " " '(a b) "bar" - nil "\n (ert-test-failed \"failure message\")\n\n\n" - ))) + nil "\n (ert-test-failed \"failure message\")\n\n\n"))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test ,skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test ,skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index c81d3d09e7d..50b8cc53a28 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -219,7 +219,7 @@ identical output." (should (eql (iter-next it -1) 42)) (should (eql (iter-next it -1) -1)))) -(ert-deftest cps-loop () +(ert-deftest cps-loop-2 () (should (equal (cl-loop for x iter-by (mygenerator 42) collect x) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index 88e689c80b8..bbceb04b49d 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -82,7 +82,7 @@ (ert-deftest let-alist-list-to-sexp () "Check that multiple dots are handled correctly." - (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t))) (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 78ecf3ff03d..8301d9906a2 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -235,7 +235,7 @@ (should (or (not mark-active) (mark))))) (ert-deftest core-elisp-tests-3-backquote () - (should (eq 3 (eval ``,,'(+ 1 2))))) + (should (eq 3 (eval ``,,'(+ 1 2) t)))) ;; Test up-list and backward-up-list. (defun lisp-run-up-list-test (fn data start instructions) @@ -324,7 +324,7 @@ start." (declare (indent 1) (debug (def-form body))) (let* ((var-pos nil) (text (with-temp-buffer - (insert (eval contents)) + (insert (eval contents t)) (goto-char (point-min)) (while (re-search-forward elisp-test-point-position-regex nil t) (push (list (intern (match-string-no-properties 1)) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 3b12f57e5ce..efa9f834110 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -383,7 +383,7 @@ but with a different end of line convention (bug#48137)." (mapc #'delete-file (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) - (directory-files-recursively dir "\\`[^\\.].*\\.el.gz\\'")))))) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'")))))) (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el index 55df4f36685..3ec20a1e8ef 100644 --- a/test/lisp/emacs-lisp/ring-tests.el +++ b/test/lisp/emacs-lisp/ring-tests.el @@ -199,7 +199,7 @@ (should (= (ring-size ring) 3)) (should (equal (ring-elements ring) '(5 4 3))))) -(ert-deftest ring-tests-insert () +(ert-deftest ring-tests-insert-2 () (let ((ring (make-ring 2))) (ring-insert+extend ring :a) (ring-insert+extend ring :b) diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index f9cfea888c7..69d59e84f6d 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -676,5 +676,23 @@ (buffer-string)) "foo\n"))) +(ert-deftest test-add-display-text-property () + (with-temp-buffer + (insert "Foo bar zot gazonk") + (add-display-text-property 4 8 'height 2.0) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + '((raise 0.5) (height 2.0)))) + (should (equal (get-text-property 9 'display) '(raise 0.5)))) + (with-temp-buffer + (insert "Foo bar zot gazonk") + (put-text-property 4 8 'display [(height 2.0)]) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + [(raise 0.5) (height 2.0)])) + (should (equal (get-text-property 9 'display) '(raise 0.5))))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index 29094526d7e..4d49e5ae70c 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -424,7 +424,7 @@ (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) (debug (form (vector &rest form)))) - `(eval (aref ,vec%%% ,arg%%%))%%%) + `(eval (aref ,vec%%% ,arg%%%) t)%%%) (defun testcover-testcase-use-nth-case (choice val) (testcover-testcase-nth-case choice diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index 84b9cea6c12..df5c264baad 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -132,7 +132,7 @@ left alone when opening a URL in an external browser." ;; Macros in BODY are expanded when the test is defined, not when it ;; is run. If a macro (possibly with side effects) is to be tested, ;; it has to be wrapped in `(eval (quote ...))'. - (eval (quote (ido-everywhere))) + (eval (quote (ido-everywhere)) t) (let ((read-file-name-function (lambda (&rest args) (expand-file-name (nth 4 args) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index d00f1ce3263..d3d58aad5f2 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -136,7 +136,7 @@ form.") ;; Prevent any dir-locals file interfering with the tests. (enable-dir-local-variables nil)) (hack-local-variables) - (eval (nth 2 test-settings))))) + (eval (nth 2 test-settings) t)))) (ert-deftest files-tests-local-variables () "Test the file-local variables implementation." @@ -465,6 +465,15 @@ unquoted file names." (let (file-name-handler-alist) (concat (file-name-sans-extension name) part (file-name-extension name t)))) +(ert-deftest files-tests-file-name-non-special-abbreviate-file-name () + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + ;; Check that abbreviation doesn't occur for quoted file names. + (should (equal (concat "/:" homedir "foo/bar") + (abbreviate-file-name (concat "/:" homedir "foo/bar")))))) + (ert-deftest files-tests-file-name-non-special-access-file () (files-tests--with-temp-non-special (tmpfile nospecial) ;; Both versions of the file name work. diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index a331ec440a8..281d97ee929 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -88,6 +88,25 @@ (test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n") (test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]"))) +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence () + "Literal replacement." + (with-substitute-command-keys-test + (test "\\`C-m'" "C-m") + (test "\\`C-m'\\`C-j'" "C-mC-j") + (test "foo\\`C-m'bar\\`C-j'baz" "fooC-mbarC-jbaz"))) + +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence-errors () + (should-error (substitute-command-keys "\\`'")) + (should-error (substitute-command-keys "\\`c-c'")) + (should-error (substitute-command-keys "\\`'"))) + +(ert-deftest help-tests-substitute-key-bindings/face-help-key-binding () + (should (eq (get-text-property 0 'face (substitute-command-keys "\\[next-line]")) + 'help-key-binding)) + (should (eq (get-text-property 0 'face (substitute-command-keys "\\`f'")) + 'help-key-binding))) + + (ert-deftest help-tests-substitute-command-keys/keymaps () (with-substitute-command-keys-test (test-re "\\{minibuffer-local-must-match-map}" @@ -174,7 +193,7 @@ M-g M-c switch-to-completions (let ((text-quoting-style 'grave)) (test "\\=`x\\='" "`x'")))) -(ert-deftest help-tests-substitute-command-keys/no-change () +(ert-deftest help-tests-substitute-command-keys/no-change-2 () (with-substitute-command-keys-test (test "\\[foobar" "\\[foobar") (test "\\=" "\\="))) diff --git a/test/lisp/mh-e/mh-thread-tests.el b/test/lisp/mh-e/mh-thread-tests.el new file mode 100644 index 00000000000..4f09677e53f --- /dev/null +++ b/test/lisp/mh-e/mh-thread-tests.el @@ -0,0 +1,131 @@ +;;; mh-thread-tests.el --- tests for mh-thread.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'mh-thread) +(eval-when-compile (require 'cl-lib)) + +(defun mh-thread-tests-before-from () + "Generate the fields of a scan line up to where the 'From' field would start. +The exact contents are not important, but the number of characters is." + (concat (make-string mh-cmd-note ?9) + (make-string mh-scan-cmd-note-width ?A) + (make-string mh-scan-destination-width ?t) + (make-string mh-scan-date-width ?/) + (make-string mh-scan-date-flag-width ?*))) + +;;; Tests of support routines + +(ert-deftest mh-thread-current-indentation-level () + "Test that `mh-thread-current-indentation-level' identifies the level." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender One] Subject of msg 1\n") + (insert (mh-thread-tests-before-from) " [Sender Two] Subject of msg 2\n") + (goto-char (point-min)) + (should (equal 0 (mh-thread-current-indentation-level))) + (forward-line) + (should (equal 2 (mh-thread-current-indentation-level))))) + +(ert-deftest mh-thread-find-children () + "Test `mh-thread-find-children'." + (let (expected-start expected-end) + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender One] line 1\n") + (setq expected-start (point)) + (insert (mh-thread-tests-before-from) " [Sender Two] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 4\n") + (setq expected-end (1- (point))) + (insert (mh-thread-tests-before-from) " [Sender Five] line 5\n") + (goto-char (1+ expected-start)) + (should (equal (list expected-start expected-end) + (mh-thread-find-children)))))) + +(ert-deftest mh-thread-immediate-ancestor () + "Test that `mh-thread-immediate-ancestor' moves to the correct message." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n") + (insert (mh-thread-tests-before-from) "[Sender One] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n") + (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n") + (forward-line -1) + (should (equal (line-number-at-pos) 6)) + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 4)) ;skips over sibling + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 3)) ;goes up only one level at a time + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 2)) + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 2)))) ;no further motion at thread root + +;;; Tests of MH-Folder Commands + +(ert-deftest mh-thread-sibling-and-ancestor () + "Test motion by `mh-thread-ancestor' and `mh-thread-next-sibling'." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n") + (insert (mh-thread-tests-before-from) "[Sender One] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n") + (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n") + (forward-line -1) + (let ((mh-view-ops '(unthread)) + (show-count 0)) + (cl-letf (((symbol-function 'mh-maybe-show) + (lambda () + (setq show-count (1+ show-count))))) + (should (equal (line-number-at-pos) 6)) + ;; test mh-thread-ancestor + (mh-thread-ancestor) + (should (equal (line-number-at-pos) 4)) ;skips over sibling + (should (equal show-count 1)) + (mh-thread-ancestor t) + (should (equal (line-number-at-pos) 2)) ;root flag skips to root + (should (equal show-count 2)) + (mh-thread-ancestor) + (should (equal (line-number-at-pos) 2)) ;do not move from root + (should (equal show-count 2)) ;do not re-show at root + ;; test mh-thread-sibling + (mh-thread-next-sibling) + (should (equal (line-number-at-pos) 2)) ;no next sibling, no motion + (should (equal show-count 2)) ;no sibling, no show + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 1)) + (should (equal show-count 3)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 1)) ;no previous sibling + (should (equal show-count 3)) + (goto-char (point-max)) + (forward-line -1) + (should (equal (line-number-at-pos) 6)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 5)) + (should (equal show-count 4)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 5)) ;no previous sibling + (should (equal show-count 4)) + )))) + +;;; mh-thread-tests.el ends here diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index d9a26e58959..f282a0b08f3 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -80,6 +80,54 @@ (mh-normalize-folder-name "+inbox////../news/" nil t))) (should (equal "+inbox/news" (mh-normalize-folder-name "+inbox////./news")))) +(ert-deftest mh-sub-folders-parse-no-folder () + "Test `mh-sub-folders-parse' with no starting folder." + (let (others-position) + (with-temp-buffer + (insert "lines without has-string are ignored\n") + (insert "onespace has no messages.\n") + (insert "twospace has no messages.\n") + (insert " precedingblanks has no messages.\n") + (insert ".leadingdot has no messages.\n") + (insert "#leadinghash has no messages.\n") + (insert ",leadingcomma has no messages.\n") + (insert "withothers has no messages ; (others)") + (setq others-position (point)) + (insert ".\n") + (insert "curf has no messages.\n") + (insert "curf+ has 123 messages.\n") + (insert "curf2+ has 17 messages.\n") + (insert "\ntotal after blank line is ignored has no messages.\n") + (should (equal + (mh-sub-folders-parse nil "curf+") + (list '("onespace") '("twospace") '("precedingblanks") + (cons "withothers" others-position) + '("curf") '("curf") '("curf2+"))))))) + +(ert-deftest mh-sub-folders-parse-relative-folder () + "Test `mh-sub-folders-parse' with folder." + (let (others-position) + (with-temp-buffer + (insert "testf+ has no messages.\n") + (insert "testf/sub1 has no messages.\n") + (insert "testf/sub2 has no messages ; (others)") + (setq others-position (point)) + (insert ".\n") + (should (equal + (mh-sub-folders-parse "+testf" "testf+") + (list '("sub1") (cons "sub2" others-position))))))) + +(ert-deftest mh-sub-folders-parse-root-folder () + "Test `mh-sub-folders-parse' with root folder." + (with-temp-buffer + (insert "/+ has no messages.\n") + (insert "/ has no messages.\n") + (insert "//nmh-style has no messages.\n") + (insert "/mu-style has no messages.\n") + (should (equal + (mh-sub-folders-parse "+/" "inbox+") + '(("") ("nmh-style") ("mu-style")))))) + ;; Folder names that are used by the following tests. (defvar mh-test-rel-folder "rela-folder") @@ -211,6 +259,10 @@ The tests use this method if no configured MH variant is found." "/abso-folder/bar has no messages." "/abso-folder/foo has no messages." "/abso-folder/food has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+/") . + ("/+ has no messages ; (others)." + "/abso-folder has no messages ; (others)." + "/tmp has no messages ; (others).")) )) (arglist (cons (file-name-base program) args))) (let ((response-list-cons (assoc arglist argument-responses))) @@ -303,6 +355,15 @@ if `mh-test-utils-debug-mocks' is non-nil." (message "file-directory-p: %S -> %s" filename result)) result)) +(defun mh-test-variant-handles-plus-slash (variant) + "Returns non-nil if this MH variant handles \"folders +/\". +Mailutils 3.5, 3.7, and 3.13 are known not to." + (cond ((not (stringp variant))) ;our mock handles it + ((string-search "GNU Mailutils" variant) + (let ((mu-version (string-remove-prefix "GNU Mailutils " variant))) + (version<= "3.13.91" mu-version))) + (t))) ;no other known failures + (ert-deftest mh-sub-folders-actual () "Test `mh-sub-folders-actual'." @@ -310,14 +371,15 @@ if `mh-test-utils-debug-mocks' is non-nil." ;; already been normalized with ;; (mh-normalize-folder-name folder nil nil t) (with-mh-test-env - (should (equal + (should (member mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders-actual nil))))) + (mapcar (lambda (x) (car x)) (mh-sub-folders-actual nil)))) ;; Empty string and "+" not tested since mh-normalize-folder-name ;; would change them to nil. - (should (equal "foo" - (car (assoc "foo" (mh-sub-folders-actual - (format "+%s" mh-test-rel-folder)))))) + (should (member "foo" + (mapcar (lambda (x) (car x)) + (mh-sub-folders-actual + (format "+%s" mh-test-rel-folder))))) ;; Folder with trailing slash not tested since ;; mh-normalize-folder-name would strip it. (should (equal @@ -328,6 +390,10 @@ if `mh-test-utils-debug-mocks' is non-nil." (list (list "bar") (list "foo") (list "food")) (mh-sub-folders-actual (format "+%s" mh-test-abs-folder)))) + (when (mh-test-variant-handles-plus-slash mh-variant-in-use) + (should (member "tmp" (mapcar (lambda (x) (car x)) + (mh-sub-folders-actual "+/"))))) + ;; FIXME: mh-sub-folders-actual doesn't (yet) expect to be given a ;; nonexistent folder. ;; (should (equal nil @@ -339,13 +405,12 @@ if `mh-test-utils-debug-mocks' is non-nil." (ert-deftest mh-sub-folders () "Test `mh-sub-folders'." (with-mh-test-env - (should (equal mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders nil))))) - (should (equal mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders ""))))) - (should (equal nil - (car (assoc mh-test-no-such-folder (mh-sub-folders - "+"))))) + (should (member mh-test-rel-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders nil)))) + (should (member mh-test-rel-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders "")))) + (should-not (member mh-test-no-such-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders "+")))) (should (equal (list (list "bar") (list "foo") (list "food")) (mh-sub-folders (format "+%s" mh-test-rel-folder)))) (should (equal (list (list "bar") (list "foo") (list "food")) @@ -356,6 +421,9 @@ if `mh-test-utils-debug-mocks' is non-nil." (mh-sub-folders (format "+%s/foo" mh-test-rel-folder)))) (should (equal (list (list "bar") (list "foo") (list "food")) (mh-sub-folders (format "+%s" mh-test-abs-folder)))) + (when (mh-test-variant-handles-plus-slash mh-variant-in-use) + (should (member "tmp" + (mapcar (lambda (x) (car x)) (mh-sub-folders "+/"))))) ;; FIXME: mh-sub-folders doesn't (yet) expect to be given a ;; nonexistent folder. @@ -437,18 +505,20 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-08-plus-slash () "Test `mh-folder-completion-function' with `+/'." - :expected-result :failed ;to be fixed in a patch by mkupfer - (mh-test-folder-completion-1 "+/" "+/" "tmp/" nil) - ;; case "bb" - (with-mh-test-env - (should (equal nil - (member (format "+%s/" mh-test-rel-folder) - (mh-folder-completion-function "+/" nil t)))))) + (with-mh-test-env + (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use))) + (mh-test-folder-completion-1 "+/" "+/" "tmp/" t) + ;; case "bb" + (with-mh-test-env + (should (equal nil + (member (format "+%s/" mh-test-rel-folder) + (mh-folder-completion-function "+/" nil t)))))) (ert-deftest mh-folder-completion-function-09-plus-slash-tmp () "Test `mh-folder-completion-function' with `+/tmp'." - :expected-result :failed ;to be fixed in a patch by mkupfer - (mh-test-folder-completion-1 "+/tmp" "+/tmp" "tmp/" t)) + (with-mh-test-env + (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use))) + (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t)) (ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () "Test `mh-folder-completion-function' with `+/abso-folder'." diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh index e917d8155bc..eaee98fcf4d 100755 --- a/test/lisp/mh-e/test-all-mh-variants.sh +++ b/test/lisp/mh-e/test-all-mh-variants.sh @@ -79,12 +79,10 @@ for path in "${mh_sys_path[@]}"; do continue fi fi - echo "Testing with PATH $path" + echo "** Testing with PATH $path" ((++tests_total)) - # The LD_LIBRARY_PATH setting is needed - # to run locally installed Mailutils. TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \ - LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \ + HOME=/nonexistent \ "${emacs[@]}" -l ert \ --eval "(setq load-prefer-newer t)" \ --eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \ diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el index f75328a59f7..2f68b9bbb24 100644 --- a/test/lisp/net/netrc-tests.el +++ b/test/lisp/net/netrc-tests.el @@ -48,7 +48,7 @@ (should (equal (netrc-credentials "ftp.example.org") '("jrh" "*baz*"))))) -(ert-deftest test-netrc-credentials () +(ert-deftest test-netrc-credentials-2 () (let ((netrc-file (ert-resource-file "netrc-folding"))) (should (equal (netrc-parse netrc-file) diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index 28c0d49cbee..9119084209e 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -61,4 +61,11 @@ ;; Only allowed in unrestricted. (should-not (puny-highly-restrictive-domain-p "I♥NY.org"))) +(ert-deftest puny-normalize () + (should (equal (puny-encode-string (string-glyph-compose "Bä.com")) + "xn--b.com-gra")) + (should (equal (puny-encode-string "Bä.com") + "xn--b.com-gra")) + (should (equal (puny-encode-string "Bä.com") "xn--b.com-gra"))) + ;;; puny-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 397e707f136..47fa18eb806 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -57,7 +57,6 @@ (declare-function tramp-check-remote-uname "tramp-sh") (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-chmod-h "tramp-sh") -(declare-function tramp-get-remote-gid "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") @@ -2289,6 +2288,46 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) +(ert-deftest tramp-test07-abbreviate-file-name () + "Check that Tramp abbreviates file names correctly." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-emacs29-p)) + (skip-unless (tramp--test-ange-ftp-p)) + + (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) + ;; Not all methods can expand "~". + (home-dir (ignore-errors (expand-file-name (concat remote-host "~"))))) + (skip-unless home-dir) + + ;; Check home-dir abbreviation. + (unless (string-suffix-p "~" home-dir) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/foo/bar"))) + (should (equal (abbreviate-file-name + (concat remote-host "/nowhere/special")) + (concat remote-host "/nowhere/special")))) + + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist + `((,(concat "\\`" (regexp-quote home-dir) "/foo") + . ,(concat home-dir "/f")) + (,(concat "\\`" (regexp-quote remote-host) "/nowhere") + . ,(concat remote-host "/nw"))))) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/f/bar"))) + (should (equal (abbreviate-file-name + (concat remote-host "/nowhere/special")) + (concat remote-host "/nw/special")))) + + ;; Check that home-dir abbreviation doesn't occur when home-dir is just "/". + (setq home-dir (concat remote-host "/")) + ;; The remote home directory is kept in the connection property + ;; "home-directory". We fake this setting. + (tramp-set-connection-property tramp-test-vec "home-directory" home-dir) + (should (equal (concat home-dir "foo/bar") + (abbreviate-file-name (concat home-dir "foo/bar")))) + (tramp-flush-connection-property tramp-test-vec "home-directory"))) + (ert-deftest tramp-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." (skip-unless (tramp--test-enabled)) @@ -3302,7 +3341,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (goto-char (point-min)) (while (not (or (eobp) (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name2)))) (forward-line 1)) (should-not (eobp)) @@ -3312,14 +3351,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Point shall still be the recent file. (should (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name2))) (should-not (re-search-forward "dired" nil t)) ;; The copied file has been inserted the line before. (forward-line -1) (should (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name3)))) (kill-buffer buffer)) @@ -6304,7 +6343,7 @@ This requires restrictions of file name syntax." (setq buffer (dired-noselect tmp-name1 "--dired -al")) (goto-char (point-min)) (while (not (eobp)) - (when-let ((name (dired-get-filename 'localp 'no-error))) + (when-let ((name (dired-get-filename 'no-dir 'no-error))) (unless (string-match-p name directory-files-no-dot-files-regexp) (should (member name files)))) @@ -6570,7 +6609,7 @@ Use the \"ls\" command." ;; Use all available language specific snippets. (lambda (x) (and - (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) + (stringp (setq x (eval (get-language-info (car x) 'sample-text) t))) ;; Filter out strings which use unencodable characters. (not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p)) (unencodable-char-position @@ -6935,7 +6974,8 @@ process sentinels. They shall not disturb each other." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. (skip-unless (not (tramp--test-emacs29-p))) (let ((default-directory tramp-test-temporary-file-directory) @@ -6955,7 +6995,8 @@ process sentinels. They shall not disturb each other." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. (skip-unless (not (tramp--test-emacs29-p))) (let ((default-directory tramp-test-temporary-file-directory) diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index 2a3bb3dafae..c87a4453cbd 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -230,6 +230,7 @@ (gnu "foo.c:8:23:information: message" 1 23 8 "foo.c") (gnu "foo.c:8.23-45: Informational: message" 1 (23 . 45) (8 . nil) "foo.c") (gnu "foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + (gnu " |foo.c:8: message" 1 nil 8 "foo.c") ;; The next one is not in the GNU standards AFAICS. ;; Here we seem to interpret it as LINE1-LINE2.COL2. (gnu "foo.c:8-45.3: message" 1 (nil . 3) (8 . 45) "foo.c") @@ -491,7 +492,7 @@ The test data is in `compile-tests--test-regexps-data'." (compilation-num-warnings-found 0) (compilation-num-infos-found 0)) (mapc #'compile--test-error-line compile-tests--test-regexps-data) - (should (eq compilation-num-errors-found 96)) + (should (eq compilation-num-errors-found 97)) (should (eq compilation-num-warnings-found 35)) (should (eq compilation-num-infos-found 28))))) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 7f1cd6795ef..63bae79bb40 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -109,7 +109,7 @@ (should (member "backup-inhibited" comps)) (should-not (member "backup-buffer" comps)))))) -(ert-deftest elisp-completes-functions-after-let-bindings () +(ert-deftest elisp-completes-functions-after-let-bindings-2 () (with-temp-buffer (emacs-lisp-mode) (insert "(let ((bar 1) (baz 2)) (ba") @@ -610,7 +610,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-defgeneric-eval - (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()))) + (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()) t)) nil) ;; Define some mode-local overloadable/overridden functions for xref to find @@ -712,7 +712,7 @@ to (xref-elisp-test-descr-to-target xref)." (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))))) (xref-elisp-deftest find-defs-defun-eval - (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()))) + (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()) t)) nil) (xref-elisp-deftest find-defs-defun-c @@ -797,7 +797,7 @@ to (xref-elisp-test-descr-to-target xref)." "DEFVAR_PER_BUFFER (\"default-directory\""))) (xref-elisp-deftest find-defs-defvar-eval - (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil))) + (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil) t)) nil) (xref-elisp-deftest find-defs-face-el @@ -815,7 +815,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-face-eval - (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil ""))) + (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil "") t)) nil) (xref-elisp-deftest find-defs-feature-el @@ -830,7 +830,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-feature-eval - (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature))) + (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature) t)) nil) (ert-deftest elisp--preceding-sexp--char-name () diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 238c9be1ab0..e02de952f2f 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -198,123 +198,123 @@ ;; These should be equivalent: (should (equal (kbd "\C-xf") (kbd "C-x f")))) -(ert-deftest subr-test-kbd-valid-p () - (should (not (kbd-valid-p ""))) - (should (kbd-valid-p "f")) - (should (kbd-valid-p "X")) - (should (not (kbd-valid-p " X"))) - (should (kbd-valid-p "X f")) - (should (not (kbd-valid-p "a b"))) - (should (not (kbd-valid-p "foobar"))) - (should (not (kbd-valid-p "return"))) +(ert-deftest subr-test-key-valid-p () + (should (not (key-valid-p ""))) + (should (key-valid-p "f")) + (should (key-valid-p "X")) + (should (not (key-valid-p " X"))) + (should (key-valid-p "X f")) + (should (not (key-valid-p "a b"))) + (should (not (key-valid-p "foobar"))) + (should (not (key-valid-p "return"))) - (should (kbd-valid-p "")) - (should (kbd-valid-p " TAB")) - (should (kbd-valid-p " RET")) - (should (kbd-valid-p " SPC")) - (should (kbd-valid-p "")) - (should (not (kbd-valid-p "[f1]"))) - (should (kbd-valid-p "")) - (should (not (kbd-valid-p "< right >"))) + (should (key-valid-p "")) + (should (key-valid-p " TAB")) + (should (key-valid-p " RET")) + (should (key-valid-p " SPC")) + (should (key-valid-p "")) + (should (not (key-valid-p "[f1]"))) + (should (key-valid-p "")) + (should (not (key-valid-p "< right >"))) ;; Modifiers: - (should (kbd-valid-p "C-x")) - (should (kbd-valid-p "C-x a")) - (should (kbd-valid-p "C-;")) - (should (kbd-valid-p "C-a")) - (should (kbd-valid-p "C-c SPC")) - (should (kbd-valid-p "C-c TAB")) - (should (kbd-valid-p "C-c c")) - (should (kbd-valid-p "C-x 4 C-f")) - (should (kbd-valid-p "C-x C-f")) - (should (kbd-valid-p "C-M-")) - (should (not (kbd-valid-p ""))) - (should (kbd-valid-p "C-RET")) - (should (kbd-valid-p "C-SPC")) - (should (kbd-valid-p "C-TAB")) - (should (kbd-valid-p "C-")) - (should (kbd-valid-p "C-c C-c C-c")) + (should (key-valid-p "C-x")) + (should (key-valid-p "C-x a")) + (should (key-valid-p "C-;")) + (should (key-valid-p "C-a")) + (should (key-valid-p "C-c SPC")) + (should (key-valid-p "C-c TAB")) + (should (key-valid-p "C-c c")) + (should (key-valid-p "C-x 4 C-f")) + (should (key-valid-p "C-x C-f")) + (should (key-valid-p "C-M-")) + (should (not (key-valid-p ""))) + (should (key-valid-p "C-RET")) + (should (key-valid-p "C-SPC")) + (should (key-valid-p "C-TAB")) + (should (key-valid-p "C-")) + (should (key-valid-p "C-c C-c C-c")) - (should (kbd-valid-p "M-a")) - (should (kbd-valid-p "M-")) - (should (not (kbd-valid-p "M-C-a"))) - (should (kbd-valid-p "C-M-a")) - (should (kbd-valid-p "M-ESC")) - (should (kbd-valid-p "M-RET")) - (should (kbd-valid-p "M-SPC")) - (should (kbd-valid-p "M-TAB")) - (should (kbd-valid-p "M-x a")) - (should (kbd-valid-p "M-")) - (should (kbd-valid-p "M-c M-c M-c")) + (should (key-valid-p "M-a")) + (should (key-valid-p "M-")) + (should (not (key-valid-p "M-C-a"))) + (should (key-valid-p "C-M-a")) + (should (key-valid-p "M-ESC")) + (should (key-valid-p "M-RET")) + (should (key-valid-p "M-SPC")) + (should (key-valid-p "M-TAB")) + (should (key-valid-p "M-x a")) + (should (key-valid-p "M-")) + (should (key-valid-p "M-c M-c M-c")) - (should (kbd-valid-p "s-SPC")) - (should (kbd-valid-p "s-a")) - (should (kbd-valid-p "s-x a")) - (should (kbd-valid-p "s-c s-c s-c")) + (should (key-valid-p "s-SPC")) + (should (key-valid-p "s-a")) + (should (key-valid-p "s-x a")) + (should (key-valid-p "s-c s-c s-c")) - (should (not (kbd-valid-p "S-H-a"))) - (should (kbd-valid-p "S-a")) - (should (kbd-valid-p "S-x a")) - (should (kbd-valid-p "S-c S-c S-c")) + (should (not (key-valid-p "S-H-a"))) + (should (key-valid-p "S-a")) + (should (key-valid-p "S-x a")) + (should (key-valid-p "S-c S-c S-c")) - (should (kbd-valid-p "H-")) - (should (kbd-valid-p "H-DEL")) - (should (kbd-valid-p "H-a")) - (should (kbd-valid-p "H-x a")) - (should (kbd-valid-p "H-c H-c H-c")) + (should (key-valid-p "H-")) + (should (key-valid-p "H-DEL")) + (should (key-valid-p "H-a")) + (should (key-valid-p "H-x a")) + (should (key-valid-p "H-c H-c H-c")) - (should (kbd-valid-p "A-H-a")) - (should (kbd-valid-p "A-SPC")) - (should (kbd-valid-p "A-TAB")) - (should (kbd-valid-p "A-a")) - (should (kbd-valid-p "A-c A-c A-c")) + (should (key-valid-p "A-H-a")) + (should (key-valid-p "A-SPC")) + (should (key-valid-p "A-TAB")) + (should (key-valid-p "A-a")) + (should (key-valid-p "A-c A-c A-c")) - (should (kbd-valid-p "C-M-a")) - (should (kbd-valid-p "C-M-")) + (should (key-valid-p "C-M-a")) + (should (key-valid-p "C-M-")) ;; Special characters. - (should (kbd-valid-p "DEL")) - (should (kbd-valid-p "ESC C-a")) - (should (kbd-valid-p "ESC")) - (should (kbd-valid-p "LFD")) - (should (kbd-valid-p "NUL")) - (should (kbd-valid-p "RET")) - (should (kbd-valid-p "SPC")) - (should (kbd-valid-p "TAB")) - (should (not (kbd-valid-p "\^i"))) - (should (not (kbd-valid-p "^M"))) + (should (key-valid-p "DEL")) + (should (key-valid-p "ESC C-a")) + (should (key-valid-p "ESC")) + (should (key-valid-p "LFD")) + (should (key-valid-p "NUL")) + (should (key-valid-p "RET")) + (should (key-valid-p "SPC")) + (should (key-valid-p "TAB")) + (should (not (key-valid-p "\^i"))) + (should (not (key-valid-p "^M"))) ;; With numbers. - (should (not (kbd-valid-p "\177"))) - (should (not (kbd-valid-p "\000"))) - (should (not (kbd-valid-p "\\177"))) - (should (not (kbd-valid-p "\\000"))) - (should (not (kbd-valid-p "C-x \\150"))) + (should (not (key-valid-p "\177"))) + (should (not (key-valid-p "\000"))) + (should (not (key-valid-p "\\177"))) + (should (not (key-valid-p "\\000"))) + (should (not (key-valid-p "C-x \\150"))) ;; Multibyte - (should (kbd-valid-p "ñ")) - (should (kbd-valid-p "ü")) - (should (kbd-valid-p "ö")) - (should (kbd-valid-p "ğ")) - (should (kbd-valid-p "ա")) - (should (not (kbd-valid-p "üüöö"))) - (should (kbd-valid-p "C-ü")) - (should (kbd-valid-p "M-ü")) - (should (kbd-valid-p "H-ü")) + (should (key-valid-p "ñ")) + (should (key-valid-p "ü")) + (should (key-valid-p "ö")) + (should (key-valid-p "ğ")) + (should (key-valid-p "ա")) + (should (not (key-valid-p "üüöö"))) + (should (key-valid-p "C-ü")) + (should (key-valid-p "M-ü")) + (should (key-valid-p "H-ü")) ;; Handle both new and old style key descriptions (bug#45536). - (should (kbd-valid-p "s-")) - (should (not (kbd-valid-p ""))) - (should (kbd-valid-p "C-M-")) - (should (not (kbd-valid-p ""))) + (should (key-valid-p "s-")) + (should (not (key-valid-p ""))) + (should (key-valid-p "C-M-")) + (should (not (key-valid-p ""))) - (should (kbd-valid-p "")) - (should (kbd-valid-p "")) + (should (key-valid-p "")) + (should (key-valid-p "")) - (should (not (kbd-valid-p "c-x"))) - (should (not (kbd-valid-p "C-xx"))) - (should (not (kbd-valid-p "M-xx"))) - (should (not (kbd-valid-p "M-x")))) + (should (not (key-valid-p "c-x"))) + (should (not (key-valid-p "C-xx"))) + (should (not (key-valid-p "M-xx"))) + (should (not (key-valid-p "M-x")))) (ert-deftest subr-test-define-prefix-command () (define-prefix-command 'foo-prefix-map) @@ -611,12 +611,13 @@ indirectly `mapbacktrace'." (ert-deftest subr-tests--dolist--wrong-number-of-args () "Test that `dolist' doesn't accept wrong types or length of SPEC, cf. Bug#25477." - (should-error (eval '(dolist (a))) - :type 'wrong-number-of-arguments) - (should-error (eval '(dolist (a () 'result 'invalid)) t) - :type 'wrong-number-of-arguments) - (should-error (eval '(dolist "foo") t) - :type 'wrong-type-argument)) + (dolist (lb '(nil t)) + (should-error (eval '(dolist (a)) lb) + :type 'wrong-number-of-arguments) + (should-error (eval '(dolist (a () 'result 'invalid)) lb) + :type 'wrong-number-of-arguments) + (should-error (eval '(dolist "foo") lb) + :type 'wrong-type-argument))) (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 2a32dc57b1c..f2031fa79ab 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -170,21 +170,13 @@ position to retrieve THING.") (forward-char -1) (should (eq (symbol-at-point) 'bar)))) -(ert-deftest test-symbol-thing-2 () - (with-temp-buffer - (insert " bar ") - (goto-char (point-max)) - (should (eq (symbol-at-point) nil)) - (forward-char -1) - (should (eq (symbol-at-point) 'bar)))) - (ert-deftest test-symbol-thing-3 () (with-temp-buffer (insert "bar") (goto-char 2) (should (eq (symbol-at-point) 'bar)))) -(ert-deftest test-symbol-thing-3 () +(ert-deftest test-symbol-thing-4 () (with-temp-buffer (insert "`[[`(") (goto-char 2) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index cb446eb486e..a049e5de58a 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -595,8 +595,12 @@ ;; incorrectly nested parens do not crash us (should-not (equal (time-stamp-string "%(stuffB" ref-time3) May)) (should-not (equal (time-stamp-string "%)B" ref-time3) May)) + ;; unterminated format does not crash us + (should-not (equal (time-stamp-string "%" ref-time3) May)) ;; not all punctuation is allowed - (should-not (equal (time-stamp-string "%&B" ref-time3) May))))) + (should-not (equal (time-stamp-string "%&B" ref-time3) May)) + (should-not (equal (time-stamp-string "%/B" ref-time3) May)) + (should-not (equal (time-stamp-string "%;B" ref-time3) May))))) (ert-deftest time-stamp-format-non-conversions () "Test that without a %, the text is copied literally." @@ -635,8 +639,8 @@ (concat Mon "." Monday "." Mon))) (should (equal (time-stamp-string "%5z.%5::z.%5z" ref-time1) "+0000.+00:00:00.+0000")) - ;; format letter is independent - (should (equal (time-stamp-string "%H:%M" ref-time1) "15:04"))))) + ;; format character is independent + (should (equal (time-stamp-string "%H:%M%%%S" ref-time1) "15:04%05"))))) (ert-deftest time-stamp-format-string-width () "Test time-stamp string width modifiers." diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index e768a165529..47ed26f609d 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -22,6 +22,7 @@ (require 'ert) (require 'ert-x) (require 'dired) +(require 'dired-x) (require 'wdired) (defvar dired-query) ; Pacify byte compiler. @@ -124,10 +125,6 @@ wdired-mode." (set-buffer-modified-p nil) (kill-buffer buf)))))))) -(defvar server-socket-dir) -(declare-function dired-smart-shell-command "dired-x" - (command &optional output-buffer error-buffer)) - (ert-deftest wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. Appended file indicators should not count as part of the file @@ -137,10 +134,10 @@ suffices to compare the return values of dired-get-filename and wdired-get-filename before and after editing." ;; FIXME: Add a test for a door (indicator ">") only under Solaris? (ert-with-temp-directory test-dir - (let* ((server-socket-dir test-dir) - (dired-listing-switches "-Fl") + (let* ((dired-listing-switches "-Fl") (dired-ls-F-marks-symlinks (eq system-type 'darwin)) - (buf (find-file-noselect test-dir))) + (buf (find-file-noselect test-dir)) + proc) (unwind-protect (progn (with-current-buffer buf @@ -148,11 +145,13 @@ wdired-get-filename before and after editing." (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) (make-symbolic-link "foo" "bar") (make-directory "foodir") - (require 'dired-x) (dired-smart-shell-command "mkfifo foopipe") - (server-force-delete) - ;; FIXME? This seems a heavy-handed way of making a socket. - (server-start) ; Add a socket file. + (when (featurep 'make-network-process '(:family local)) + (setq proc (make-network-process + :name "foo" + :family 'local + :server t + :service (expand-file-name "foosocket" test-dir)))) (kill-buffer buf)) (dired test-dir) (dired-toggle-read-only) @@ -172,7 +171,7 @@ wdired-get-filename before and after editing." (setq dir (dired-get-filename 'no-dir t))) (should (equal dir (pop names))))))) (kill-buffer (get-buffer test-dir)) - (server-force-delete))))) + (ignore-errors (delete-process proc)))))) (ert-deftest wdired-test-bug39280 () "Test for https://debbugs.gnu.org/39280." diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 7943ac2ec26..9b7023d18b9 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -147,7 +147,7 @@ with parameters from the *Messages* buffer modification." (defmacro deftest-overlayp-1 (id arg-expr should-expr) (declare (indent 1)) - `(ert-deftest ,(buffer-tests--make-test-name 'overlay-buffer 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlayp 1 id) () (with-temp-buffer (should (equal ,should-expr (overlayp ,arg-expr)))))) @@ -436,14 +436,14 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 I 10 (point-max) (10 10)) (deftest-next-overlay-change-1 J 20 (point-max) (10 10)) ;; 2 non-empty, non-intersecting -(deftest-next-overlay-change-1 D 10 20 (20 30) (40 50)) -(deftest-next-overlay-change-1 E 35 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 F 60 (point-max) (20 30) (40 50)) -(deftest-next-overlay-change-1 G 30 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 H 50 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 D2 10 20 (20 30) (40 50)) +(deftest-next-overlay-change-1 E2 35 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 F2 60 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 G2 30 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 H2 50 (point-max) (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-next-overlay-change-1 I 10 20 (20 30) (25 35)) -(deftest-next-overlay-change-1 J 20 25 (20 30) (25 35)) +(deftest-next-overlay-change-1 I2 10 20 (20 30) (25 35)) +(deftest-next-overlay-change-1 J2 20 25 (20 30) (25 35)) (deftest-next-overlay-change-1 K 23 25 (20 30) (25 35)) (deftest-next-overlay-change-1 L 25 30 (20 30) (25 35)) (deftest-next-overlay-change-1 M 28 30 (20 30) (25 35)) @@ -473,11 +473,11 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) (deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting at end -(deftest-next-overlay-change-1 h 10 20 (30 30) (20 30)) -(deftest-next-overlay-change-1 i 20 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 j 25 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) -(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 h2 10 20 (30 30) (20 30)) +(deftest-next-overlay-change-1 i2 20 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 j2 25 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 k2 30 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 l2 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting in the middle (deftest-next-overlay-change-1 m 10 20 (25 25) (20 30)) (deftest-next-overlay-change-1 n 20 25 (25 25) (20 30)) @@ -524,14 +524,14 @@ with parameters from the *Messages* buffer modification." (deftest-previous-overlay-change-1 I 10 1 (10 10)) (deftest-previous-overlay-change-1 J 20 10 (10 10)) ;; 2 non-empty, non-intersecting -(deftest-previous-overlay-change-1 D 10 1 (20 30) (40 50)) -(deftest-previous-overlay-change-1 E 35 30 (20 30) (40 50)) -(deftest-previous-overlay-change-1 F 60 50 (20 30) (40 50)) -(deftest-previous-overlay-change-1 G 30 20 (20 30) (40 50)) -(deftest-previous-overlay-change-1 H 50 40 (20 30) (40 50)) +(deftest-previous-overlay-change-1 D2 10 1 (20 30) (40 50)) +(deftest-previous-overlay-change-1 E2 35 30 (20 30) (40 50)) +(deftest-previous-overlay-change-1 F2 60 50 (20 30) (40 50)) +(deftest-previous-overlay-change-1 G2 30 20 (20 30) (40 50)) +(deftest-previous-overlay-change-1 H2 50 40 (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-previous-overlay-change-1 I 10 1 (20 30) (25 35)) -(deftest-previous-overlay-change-1 J 20 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 I2 10 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 J2 20 1 (20 30) (25 35)) (deftest-previous-overlay-change-1 K 23 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 L 25 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 M 28 25 (20 30) (25 35)) @@ -621,28 +621,28 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-at-1 P 50 () (a 10 20) (b 30 40)) ;; 2 non-empty overlays intersecting -(deftest-overlays-at-1 G 1 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 H 10 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 I 15 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 K 20 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 L 25 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 M 30 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 N 35 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 O 40 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 P 50 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 G2 1 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 H2 10 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 I2 15 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 K2 20 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 L2 25 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 M2 30 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 N2 35 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 O2 40 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 P2 50 () (a 10 30) (b 20 40)) ;; 2 non-empty overlays continuous -(deftest-overlays-at-1 G 1 () (a 10 20) (b 20 30)) -(deftest-overlays-at-1 H 10 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 I 15 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 K 20 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 L 25 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 M 30 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 G3 1 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 H3 10 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 I3 15 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 K3 20 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 L3 25 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 M3 30 () (a 10 20) (b 20 30)) ;; overlays-at never returns empty overlays. -(deftest-overlays-at-1 N 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 O 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 P 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 N3 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 O3 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 P3 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 Q 40 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 R 50 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 S 60 () (a 1 60) (c 1 1) (b 30 30) (d 50 50)) @@ -1109,7 +1109,7 @@ with parameters from the *Messages* buffer modification." (should (eq ov (car (overlays-in 1 1))))))))) ;; properties -(ert-deftest test-buffer-swap-text-1 () +(ert-deftest test-buffer-swap-text-2 () (buffer-tests--with-temp-buffers (buffer other) (with-current-buffer other (overlay-put (make-overlay 1 1) 'buffer 'other)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 025bc2058ec..5b20cf38ec6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -28,17 +28,23 @@ (require 'ert) (require 'ert-x) (require 'cl-lib) +(require 'comp) +(require 'comp-cstr) -(defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) +(eval-and-compile + (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))) -(defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) - -(when (featurep 'native-compile) - (require 'comp) +(when (native-comp-available-p) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) +;; Load the test code here so the compiler can check the function +;; names used in this file. +(require 'comp-test-funcs comp-test-src) +(require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name! + (defmacro comp-deftest (name args &rest docstring-and-body) "Define a test for the native compiler tagging it as :nativecomp." (declare (indent defun) @@ -66,7 +72,7 @@ Check that the resulting binaries do not differ." (copy-file comp-src comp2-src t) (let ((load-no-native t)) (load (concat comp-src "c") nil nil t t)) - (should-not (subr-native-elisp-p (symbol-function #'native-compile))) + (should-not (subr-native-elisp-p (symbol-function 'native-compile))) (message "Compiling stage1...") (let* ((t0 (current-time)) (comp1-eln (native-compile comp1-src))) @@ -352,6 +358,8 @@ Check that the resulting binaries do not differ." comp-test-interactive-form2-f))) (should-not (commandp #'comp-tests-doc-f))) +(declare-function comp-tests-free-fun-f nil) + (comp-deftest free-fun () "Check we are able to compile a single function." (eval '(defun comp-tests-free-fun-f () @@ -361,7 +369,7 @@ Check that the resulting binaries do not differ." t) (native-compile #'comp-tests-free-fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-free-fun-f))) (should (= (comp-tests-free-fun-f) 3)) (should (string= (documentation #'comp-tests-free-fun-f) "Some doc.")) @@ -369,11 +377,13 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(declare-function comp-tests/free\fun-f nil) + (comp-deftest free-fun-silly-name () "Check we are able to compile a single function." (eval '(defun comp-tests/free\fun-f ()) t) (native-compile #'comp-tests/free\fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + (should (subr-native-elisp-p (symbol-function 'comp-tests/free\fun-f)))) (comp-deftest bug-40187 () "Check function name shadowing. @@ -384,7 +394,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest speed--1 () "Check that at speed -1 we do not native compile." (should (= (comp-test-speed--1-f) 3)) - (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-speed--1-f)))) (comp-deftest bug-42360 () "." @@ -433,7 +443,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest primitive-redefine () "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) - ((symbol-function #'-) + ((symbol-function '-) (lambda (&rest args) (setq comp-test-primitive-redefine-args args) 'xxx))) @@ -454,11 +464,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest comp-test-defsubst () ;; Bug#42664, Bug#43280, Bug#44209. - (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-defsubst-f)))) (comp-deftest primitive-redefine-compile-44221 () "Test the compiler still works while primitives are redefined (bug#44221)." - (cl-letf (((symbol-function #'delete-region) + (cl-letf (((symbol-function 'delete-region) (lambda (_ _)))) (should (subr-native-elisp-p (native-compile @@ -494,12 +504,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest 45603-1 () "" (load (native-compile (ert-resource-file "comp-test-45603.el"))) - (should (fboundp #'comp-test-45603--file-local-name))) + (should (fboundp 'comp-test-45603--file-local-name))) (comp-deftest 46670-1 () "" (should (string= (comp-test-46670-2-f "foo") "foo")) - (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + (should (equal (subr-type (symbol-function 'comp-test-46670-2-f)) '(function (t) t)))) (comp-deftest 46824-1 () @@ -729,7 +739,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest dynamic-help-arglist () "Test `help-function-arglist' works on lisp/d (bug#42572)." (should (equal (help-function-arglist - (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + (symbol-function 'comp-tests-ffuncall-callee-opt-rest-dyn-f) t) '(a b &optional c &rest d)))) @@ -786,6 +796,8 @@ Return a list of results." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) insn))))))) +(declare-function comp-tests-tco-f nil) + (comp-deftest tco () "Check for tail recursion elimination." (let ((native-comp-speed 3) @@ -800,7 +812,7 @@ Return a list of results." (comp-tests-tco-f (+ a b) a (- count 1)))) t) (native-compile #'comp-tests-tco-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) (defun comp-tests-fw-prop-checker-1 (_) @@ -814,6 +826,8 @@ Return a list of results." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))))) +(declare-function comp-tests-fw-prop-1-f nil) + (comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((native-comp-speed 2) @@ -825,7 +839,7 @@ Return a list of results." (length c))) ; <= has to optimize t) (native-compile #'comp-tests-fw-prop-1-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) (defun comp-tests-check-ret-type-spec (func-form ret-type) @@ -1405,11 +1419,13 @@ folded." (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) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-caller-f))) (should (= (comp-tests-pure-caller-f) 4)) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-fibn-entry-f))) (should (= (comp-tests-pure-fibn-entry-f) 6765)))) (defvar comp-tests-cond-rw-checked-function nil diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 756c41b6ff3..dfc12735bda 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -419,7 +419,7 @@ comparing the subr with a much slower Lisp implementation." "Test setting a keyword constant." (with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant))) -(ert-deftest binding-test-set-constant-nil () +(ert-deftest binding-test-set-constant-itself () "Test setting a keyword to itself." (with-no-warnings (should (setq :keyword :keyword)))) @@ -690,7 +690,7 @@ comparing the subr with a much slower Lisp implementation." (let ((n (* 2 most-negative-fixnum))) (should (= (logand -1 n) n)))) -(ert-deftest data-tests-logcount () +(ert-deftest data-tests-logcount-2 () (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128))) (ert-deftest data-tests-logior () diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 442bca5facb..988b311f5b5 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -247,6 +247,7 @@ must evaluate to a regular expression string." (ert-deftest module--test-assertions--load-non-live-object () "Check that -module-assertions verify that non-live objects aren't accessed." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -265,6 +266,7 @@ must evaluate to a regular expression string." This differs from `module--test-assertions-load-non-live-object' in that it stows away a global reference. The module assertions should nevertheless detect the invalid load." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -281,6 +283,7 @@ should nevertheless detect the invalid load." (ert-deftest module--test-assertions--call-emacs-from-gc () "Check that -module-assertions prevents calling Emacs functions during garbage collection." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -292,7 +295,8 @@ during garbage collection." (ert-deftest module--test-assertions--globref-invalid-free () "Check that -module-assertions detects invalid freeing of a local reference." - (skip-unless (or (file-executable-p mod-test-emacs) + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) (module--test-assertion diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 3c3e7033419..727c98aa5fa 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -86,23 +86,27 @@ Bug#24912." (ert-deftest eval-tests--if-dot-string () "Check that Emacs rejects (if . \"string\")." - (should-error (eval '(if . "abc")) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") t) :type 'wrong-type-argument) (let ((if-tail (list '(setcdr if-tail "abc") t))) - (should-error (eval (cons 'if if-tail)))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable)) (let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t))) - (should-error (eval (cons 'if if-tail))))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable))) (ert-deftest eval-tests--let-with-circular-defs () "Check that Emacs reports an error for (let VARS ...) when VARS is circular." (let ((vars (list 'v))) (setcdr vars vars) (dolist (let-sym '(let let*)) - (should-error (eval (list let-sym vars)))))) + (should-error (eval (list let-sym vars) nil))))) (ert-deftest eval-tests--mutating-cond () "Check that Emacs doesn't crash on a cond clause that mutates during eval." (let ((clauses (list '((progn (setcdr clauses "ouch") nil))))) - (should-error (eval (cons 'cond clauses))))) + (should-error (eval (cons 'cond clauses) nil)) + (should-error (eval (cons 'cond clauses) t)))) (defun eval-tests--exceed-specbind-limit () (defvar eval-tests--var1) @@ -179,12 +183,13 @@ are found on the stack and therefore not garbage collected." "Remove the Lisp reference to the byte-compiled object." (setf (symbol-function #'eval-tests-33014-func) nil)) -(defun eval-tests-19790-backquote-comma-dot-substitution () +(ert-deftest eval-tests-19790-backquote-comma-dot-substitution () "Regression test for Bug#19790. Don't handle destructive splicing in backquote expressions (like in Common Lisp). Instead, make sure substitution in backquote expressions works for identifiers starting with period." - (should (equal (let ((.x 'identity)) (eval `(,.x 'ok))) 'ok))) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok)) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) 'ok))) (ert-deftest eval-tests/backtrace-in-batch-mode () (let ((emacs (expand-file-name invocation-name invocation-directory))) diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index 8e28faf2b26..629d6c55849 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -373,6 +373,40 @@ g .. h foo (should (eq (lookup-key (current-global-map) ["C-x C-f"]) 'find-file)) (should (eq (lookup-key (current-global-map) [?\C-x ?\C-f]) 'find-file))) +(ert-deftest keymap-removal () + ;; Set to nil. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil) + (should (equal map '(keymap (97))))) + ;; Remove. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil t) + (should (equal map '(keymap))))) + +(ert-deftest keymap-removal-inherit () + ;; Set to nil. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil) + (should (eq (lookup-key child [?a]) nil))) + ;; Remove. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil t) + (should (eq (lookup-key child [?a]) 'foo)))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index be685fe999f..c635c592b28 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -115,6 +115,10 @@ (should-error (read "#24r") :type 'invalid-read-syntax) (should-error (read "#") :type 'invalid-read-syntax)) +(ert-deftest lread-char-modifiers () + (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) + (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))) + (ert-deftest lread-record-1 () (should (equal '(#s(foo) #s(foo)) (read "(#1=#s(foo) #1#)")))) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index b831ca3bdaa..f14a460d1a5 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -787,6 +787,7 @@ have written output." (list (list process "finished\n")))))))))) (ert-deftest process-tests/multiple-threads-waiting () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (fboundp 'make-thread)) (with-timeout (60 (ert-fail "Test timed out")) (process-tests--with-processes processes diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index cc67aef8e15..ae4aacd9c7c 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -154,4 +154,20 @@ int main () { nil) 138)))) +(ert-deftest test-get-display-property () + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '(height 2.0))) + (should (equal (get-display-property 2 'height) 2.0))) + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '((height 2.0) + (space-width 2.0)))) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 2.0))) + (with-temp-buffer + (insert (propertize "foo bar" 'face 'bold + 'display '[(height 2.0) + (space-width 20)])) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 20)))) + ;;; xdisp-tests.el ends here